home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1995 November / EnigmA AMIGA RUN 02 (1995)(G.R. Edizioni)(IT)[!][issue 1995-11][Skylink CD].iso / earcd / program / misc / obrn-a_1.lha / oberon-a / src_upd1.lha / source / oc / OCC.mod < prev    next >
Text File  |  1995-07-13  |  74KB  |  2,549 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCC.mod $
  4.   Description: Code generation
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.23 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/14 00:42:12 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *>
  21.  
  22. MODULE OCC;
  23.  
  24. IMPORT
  25.   SYS := SYSTEM, Files, Str := Strings, OCM, OCS, OCT, OCStrings, OCOut;
  26.  
  27.  
  28. (* --- Exported declarations ------------------------------------------ *)
  29.  
  30.  
  31. CONST
  32.  
  33.   (* Condition codes *)
  34.  
  35.    T * =  0;  F * =  1; HI * =  2; LS * =  3; CC * =  4; CS * =  5;
  36.   NE * =  6; EQ * =  7; VC * =  8; VS * =  9; PL * = 10; MI * = 11;
  37.   GE * = 12; LT * = 13; GT * = 14; LE * = 15;
  38.  
  39.   (* Instruction mnemonics *)
  40.  
  41.   Bcc  * = 6000H;  DBcc * = 50C8H;  Scc * = 50C0H;
  42.  
  43.   ADD  * = 0D000H; ADDI * = 0600H;  ADDQ * = 5000H;  AND  * = 0C000H;
  44.   ANDI * = 0200H;  ASL  * = 0E100H; ASR  * = 0E000H; BCC  * = 6400H;
  45.   BCLR * = 0080H;  BCS  * = 6500H;  BEQ  * = 6700H;  BGE  * = 6C00H;
  46.   BGT  * = 6E00H;  BHI  * = 6200H;  BLE  * = 6F00H;  BLS  * = 6300H;
  47.   BLT  * = 6D00H;  BMI  * = 6B00H;  BNE  * = 6600H;  BPL  * = 6A00H;
  48.   BRA  * = 6000H;  BSET * = 00C0H;  BSR  * = 6100H;  BTST * = 0000H;
  49.   BVC  * = 6800H;  BVS  * = 6900H;  CHK  * = 4180H;  CLR  * = 4200H;
  50.   CMP  * = 0B000H; CMPI * = 0C00H;  DBCC * = 54C8H;  DBCS * = 55C8H;
  51.   DBEQ * = 57C8H;  DBF  * = 51C8H;  DBGE * = 5CC8H;  DBGT * = 5EC8H;
  52.   DBHI * = 52C8H;  DBLE * = 5FC8H;  DBLS * = 53C8H;  DBLT * = 5DC8H;
  53.   DBMI * = 5BC8H;  DBNE * = 56C8H;  DBPL * = 5AC8H;  DBRA * = 50C8H;
  54.   DBT  * = 50C8H;  DBVC * = 58C8H;  DBVS * = 59C8H;  DIVS * = 081C0H;
  55.   EOR  * = 0B100H; EORI * = 0A00H;  EXG  * = 0C140H; EXTW * = 4880H;
  56.   EXTL * = 48C0H;  JMP  * = 4EC0H;  JSR  * = 4E80H;  LEA  * = 41C0H;
  57.   LINK * = 4E50H;  LSL  * = 0E108H; LSR  * = 0E008H; MOVEQ* = 7000H;
  58.   MULS * = 0C1C0H; NEG  * = 4400H;  NOP  * = 4E71H;  NOT  * = 4600H;
  59.   iOR  * = 08000H; ORI  * = 0000H;  PEA  * = 4840H;  ROL  * = 0E118H;
  60.   ROR  * = 0E018H; RTE  * = 4E73H;  RTS  * = 4E75H;  SCS  * = 55C0H;
  61.   SEQ  * = 57C0H;  SF   * = 51C0H;  SGE  * = 5CC0H;  SGT  * = 5EC0H;
  62.   SHI  * = 52C0H;  SLE  * = 5FC0H;  SLS  * = 53C0H;  SLT  * = 5DC0H;
  63.   SMI  * = 5BC0H;  SNE  * = 56C0H;  SPL  * = 5AC0H;  SRA  * = 50C0H;
  64.   ST   * = 50C0H;  SVC  * = 58C0H;  SVS  * = 59C0H;  SUB  * = 9000H;
  65.   SUBI * = 0400H;  SUBQ * = 5100H;  SWAP * = 4840H;  TRAP * = 4E40H;
  66.   TRAPV* = 4E76H;  TST  * = 4A00H;  UNLK * = 4E58H;
  67.  
  68.   (* Trap numbers *)
  69.  
  70.   OverflowCheck * = -1;
  71.   IndexCheck *    = 0;
  72.   TypeCheck *     = 1;
  73.   NilCheck *      = 2;
  74.   CaseCheck *     = 3;
  75.   ReturnCheck *   = 4;
  76.   StackCheck *    = 5;
  77.   RangeCheck *    = 6;
  78.  
  79.   (* CPU Registers *)
  80.  
  81.   D0 = 0; D1 = 1; D2 = 2; D3 = 3; D7 = 7;
  82.   A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  83.   A6 = 14; A7 = 15; BP = A4 - 8; FP = A5 - 8; SP = A7 - 8;
  84.   DataRegs = {D0 .. D7};
  85.   AdrRegs = {A0 .. A7};
  86.  
  87.   (* Register masks for SaveRegisters () *)
  88.  
  89.   ScratchRegs * = {D0, D1, A0, A1};
  90.   AllRegs * = {D0 .. A3, A6};
  91.  
  92.   (* Procedures in Kernel *)
  93.  
  94.   kHalt *            = 0;
  95.   kNewRecord *       = 1;
  96.   kNewArray *        = 2;
  97.   kNewSysBlk *       = 3;
  98.   kDispose *         = 4;
  99.   kInitGC *          = 5;
  100.   kMove *            = 6;
  101.   kStackChk *        = 7;
  102.   kMul32 *           = 8;
  103.   kDiv32 *           = 9;
  104.   kSPFix *           = 10;
  105.   kSPFlt *           = 11;
  106.   kSPCmp *           = 12;
  107.   kSPTst *           = 13;
  108.   kSPNeg *           = 14;
  109.   kSPAdd *           = 15;
  110.   kSPSub *           = 16;
  111.   kSPMul *           = 17;
  112.   kSPDiv *           = 18;
  113.   kSPAbs *           = 19;
  114.   kInit *            = 20;
  115.   kEnd *             = 21;
  116.   kRegisterModule *  = 22;
  117.   kRegisterType *    = 23;
  118.   kRegisterCommand * = 24;
  119.   numKProcs          = 25;
  120.  
  121. TYPE
  122.  
  123.   RegState *= RECORD
  124.     regs *: SET;
  125.     obj : ARRAY 16 OF OCT.Object;
  126.     count : ARRAY 16 OF SHORTINT;
  127.   END; (* RegState *)
  128.  
  129. VAR
  130.   pc * : LONGINT;
  131.   level * : INTEGER;
  132.   wasderef * : OCT.Object;
  133.   regState * : RegState;
  134.   genCode * : BOOLEAN;
  135.  
  136.  
  137. (* --- Local declarations ----------------------------------------------- *)
  138.  
  139. CONST
  140.   (* MaxBufferSize  = 32766; *)
  141.   (* MaxCodeLength  = MaxBufferSize DIV SIZE (INTEGER); *)
  142.   (* MaxConstLength = MaxBufferSize DIV SIZE (CHAR); *)
  143.   NumTypes       = 64;
  144.  
  145.   (* Object file hunk types *)
  146.  
  147.   hunkUnit       =  999; hunkName       = 1000; hunkCode         = 1001;
  148.   hunkData       = 1002; hunkBSS        = 1003; hunkReloc32      = 1004;
  149.   hunkReloc16    = 1005; hunkReloc8     = 1006; hunkExt          = 1007;
  150.   hunkSymbol     = 1008; hunkDebug      = 1009; hunkEnd          = 1010;
  151.   hunkHeader     = 1011; hunkOverlay    = 1013; hunkBreak        = 1014;
  152.   hunkDRel32     = 1015; hunkDRel16     = 1016; hunkDRel8        = 1017;
  153.   hunkLib        = 1018; hunkIndex      = 1019; hunkReloc32Short = 1020;
  154.   hunkRelReloc32 = 1021; hunkAbsReloc16 = 1022;
  155.  
  156.   hunkAdvisory   = 29;   hunkChip       = 30;   hunkFast         = 31;
  157.  
  158.   (* Hunk names *)
  159.   hunkSmallCode = "SMALLCODE";
  160.   hunkSmallData = "SMALLDATA";
  161.   hunkMerged    = "__MERGED";
  162.  
  163.   (* External symbol types *)
  164.   extSymb      =   0; extDef      =   1; extAbs      =   2;
  165.   extRes       =   3; extRef32    = 129; extCommon   = 130;
  166.   extRef16     = 131; extRef8     = 132; extDExt32   = 133;
  167.   extDExt16    = 134; extDExt8    = 135; extRelRef32 = 136;
  168.   extRelCommon = 137; extAbsRef16 = 138; extAbsRef8  = 139;
  169.  
  170.   (* Addressing mode flag values *)
  171.  
  172.   DReg   = 0; (* Data Register *)
  173.   ARDir  = 1; (* Address Register Direct *)
  174.   ARInd  = 2; (* Address Register Indirect *)
  175.   ARPost = 3; (* Address Register with Post-Increment *)
  176.   ARPre  = 4; (* Address Register with Pre-Decrement *)
  177.   ARDisp = 5; (* Address Register with Displacement *)
  178.   ARDisX = 6; (* Address Register with Disp. & Index *)
  179.   Mode7  = 7;
  180.   AbsW   = 0; (* Absolute Short (16-bit Address) *)
  181.   AbsL   = 1; (* Absolute Long (32-bit Address) *)
  182.   PCDisX = 3; (* Program Counter Relative, with Disp. & Index *)
  183.   Imm    = 4; (* Immediate *)
  184.   PCDisp = 5; (* Program Counter Relative, with Displacement *)
  185.  
  186.   B = 1; W = 2; L = 4; (* Size types *)
  187.  
  188.   (* object modes *)
  189.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  190.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  191.   Abs = OCM.Abs; Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop;
  192.   Coc = OCM.Coc; Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ;
  193.   LProc = OCM.LProc; XProc = OCM.XProc; SProc = OCM.SProc;
  194.   LibCall = OCM.LibCall; TProc = OCM.TProc; Mod = OCM.Mod;
  195.   Head = OCM.Head; RList = OCM.RList; M2Proc = OCM.M2Proc;
  196.   CProc = OCM.CProc; AProc = OCM.AProc; VarR = OCM.VarR; IndR = OCM.IndR;
  197.   CallBack = OCM.CallBack;
  198.  
  199.   (* structure forms *)
  200.   Undef = OCT.Undef; Pointer = OCT.Pointer; Array = OCT.Array;
  201.   Record = OCT.Record; ProcTyp = OCT.ProcTyp; PtrTyp = OCT.PtrTyp;
  202.  
  203.   (* System flags *)
  204.  
  205.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  206.   AsmFlag = OCM.AsmFlag;
  207.  
  208. TYPE
  209.  
  210.   CodeHunk = POINTER TO CodeHunkDesc;
  211.   Def = POINTER TO DefDesc;
  212.   Ref = POINTER TO RefDesc;
  213.   Offset = POINTER TO OffsetDesc;
  214.  
  215.   CodeHunkDesc = RECORD
  216.     next   : CodeHunk;
  217.     start,
  218.     length : LONGINT;
  219.     defs   : Def;
  220.     refs   : Ref;
  221.   END; (* CodeHunkDesc *)
  222.  
  223.   DefDesc = RECORD
  224.     next   : Def;
  225.     object : OCT.Object;
  226.     offset : LONGINT;
  227.   END; (* DefDesc *)
  228.  
  229.   RefDesc = RECORD
  230.     next    : Ref;
  231.     type    : INTEGER;
  232.     label   : OCT.Label;
  233.     count   : LONGINT;
  234.     offsets : Offset;
  235.   END; (* RefDesc *)
  236.  
  237.   OffsetDesc = RECORD
  238.     next : Offset;
  239.     n    : LONGINT;
  240.   END; (* OffsetDesc *)
  241.  
  242. VAR
  243.   (* Labels in Module Kernel *)
  244.   kernelLab : ARRAY numKProcs OF OCT.Label;
  245.   i : INTEGER;
  246.  
  247.   FirstCodeHunk, CurrCodeHunk, InitCodeHunk, Prologue : CodeHunk;
  248.   codex, conx : LONGINT;
  249.   typex : INTEGER;
  250.   CodeLength, ConstLength : LONGINT;
  251.   code : POINTER TO ARRAY OF INTEGER;
  252.   constant : POINTER TO ARRAY OF CHAR;
  253.   type : ARRAY NumTypes OF OCT.Struct;
  254.   dataCount, numPtrs : LONGINT;
  255.  
  256. TYPE
  257.  
  258.   Arg = RECORD
  259.     form  : INTEGER;
  260.     data  : LONGINT;
  261.     label : OCT.Label;
  262.   END; (* Arg *)
  263.  
  264. CONST
  265.   (* Arg forms *)
  266.   none = 0; word = 1; long = 2;
  267.  
  268.   (* Ref types *)
  269.   wordRef = 3; longRef = 4; smallRef = 5;
  270.  
  271. (* --- Procedure declarations ------------------------------------------- *)
  272.  
  273.  
  274. (*------------------------------------*)
  275. PROCEDURE OpenBuffers* ( codeSize, constSize : LONGINT );
  276. BEGIN (* OpenBuffers *)
  277.   CodeLength := codeSize DIV 2; ConstLength := constSize;
  278.   IF (CodeLength > 0) & (ConstLength > 0) THEN
  279.     NEW (code, CodeLength); NEW (constant, ConstLength);
  280.     IF (code # NIL) & (constant # NIL) THEN RETURN END
  281.   END;
  282.   OCOut.Str0 (OCStrings.OCC1);
  283.   HALT (20)
  284. END OpenBuffers;
  285.  
  286. (*------------------------------------*)
  287. PROCEDURE Init * ();
  288.  
  289.   VAR r : INTEGER;
  290.  
  291. BEGIN (* Init *)
  292.   pc := 0; level := 0; conx := 0; codex := 0; typex := 0;
  293.   regState.regs := {}; genCode := TRUE;
  294.   FOR r := 0 TO 15 DO regState.obj[r] := NIL; regState.count[r] := 0 END;
  295.   OCT.ModuleInit ("Kernel", kernelLab [kInit]);
  296. END Init;
  297.  
  298. (*------------------------------------*)
  299. PROCEDURE Close * ();
  300.  
  301.   VAR i : INTEGER;
  302.  
  303. BEGIN (* Close *)
  304.   FirstCodeHunk := NIL; CurrCodeHunk := NIL; InitCodeHunk := NIL;
  305.   Prologue := NIL;
  306.   i := 0; WHILE i < NumTypes DO type [i] := NIL; INC (i) END
  307. END Close;
  308.  
  309. (*------------------------------------*)
  310. PROCEDURE StartModule* (name : ARRAY OF CHAR);
  311.   VAR i : INTEGER; ch : CHAR;
  312. <*$CopyArrays-*>
  313. BEGIN (* StartModule *)
  314.   i := 0;
  315.   REPEAT
  316.     IF conx >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  317.     <*$ < NilChk- IndexChk- *>
  318.     ch := name [i]; constant [conx] := ch;
  319.     <*$ > *>
  320.     INC (i); INC (conx)
  321.   UNTIL ch = 0X;
  322. END StartModule;
  323.  
  324. (*------------------------------------*)
  325. PROCEDURE StartPrologue * ();
  326.  
  327.   VAR codeHunk : CodeHunk;
  328.  
  329. BEGIN (* StartPrologue *)
  330.   NEW (codeHunk);
  331.   FirstCodeHunk := codeHunk; CurrCodeHunk := codeHunk;
  332.   codeHunk.next := NIL; codeHunk.start := codex; codeHunk.length := 0;
  333.   codeHunk.defs := NIL; codeHunk.refs := NIL;
  334.   Prologue := codeHunk
  335. END StartPrologue;
  336.  
  337. (*------------------------------------*)
  338. PROCEDURE StartCodeHunk * (initProc : BOOLEAN);
  339.  
  340.   VAR codeHunk : CodeHunk;
  341.  
  342. BEGIN (* StartCodeHunk *)
  343.   NEW (codeHunk);
  344.   IF FirstCodeHunk = NIL THEN
  345.     FirstCodeHunk := codeHunk; CurrCodeHunk := codeHunk
  346.   ELSE
  347.     CurrCodeHunk.next := codeHunk; CurrCodeHunk := codeHunk;
  348.   END; (* ELSE *)
  349.   codeHunk.next := NIL; codeHunk.start := codex; codeHunk.length := 0;
  350.   codeHunk.defs := NIL; codeHunk.refs := NIL;
  351.   IF initProc THEN InitCodeHunk := codeHunk END;
  352. END StartCodeHunk;
  353.  
  354. (*------------------------------------*)
  355. PROCEDURE StartProcedure * (proc : OCT.Object);
  356.  
  357.   VAR def : Def;
  358.  
  359. BEGIN (* StartProcedure *)
  360.   NEW (def);
  361.   def.next := CurrCodeHunk.defs; CurrCodeHunk.defs := def;
  362.   def.object := proc; def.offset := pc - (CurrCodeHunk.start * 2);
  363. END StartProcedure;
  364.  
  365. (*------------------------------------*)
  366. PROCEDURE EndCodeHunk * ();
  367.  
  368. BEGIN (* EndCodeHunk *)
  369.   CurrCodeHunk.length := codex - CurrCodeHunk.start;
  370. END EndCodeHunk;
  371.  
  372. (*------------------------------------*)
  373. PROCEDURE AllocString *
  374.   (VAR s : ARRAY OF CHAR; len : LONGINT; VAR x : OCT.Item);
  375.  
  376.   VAR i : LONGINT;
  377.  
  378. BEGIN (* AllocString *)
  379.   IF len = 0 THEN
  380.     x.lev := 0; x.a0 := -1; x.a1 := 1; x.a2 := 0; x.label := NIL
  381.   ELSIF len = 1 THEN
  382.     x.lev := 0; x.a0 := -1; x.a1 := 2; x.a2 := ORD (s [0]); x.label := NIL
  383.   ELSE
  384.     i := 0;
  385.     IF (conx + len) >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  386.     REPEAT
  387.       <*$ < NilChk- IndexChk- *>
  388.       constant [conx] := s [i];
  389.       <*$ > *>
  390.       INC (i); INC (conx)
  391.     UNTIL i = len + 1;
  392.     x.lev := 0; x.a0 := conx - i; x.a1 := i; x.a2 := 0;
  393.     x.label := OCT.ConstLabel
  394.   END;
  395.   x.obj := NIL
  396. END AllocString;
  397.  
  398. (*------------------------------------*)
  399. PROCEDURE AllocStringFromChar * (VAR x : OCT.Item);
  400.  
  401. BEGIN (* AllocStringFromChar *)
  402.   IF x.a1 > 2 THEN OCS.Mark (212)
  403.   ELSIF x.a0 < 0 THEN
  404.     IF x.a1 = 1 THEN
  405.       IF conx = 0 THEN
  406.         <*$ < NilChk- IndexChk- *>
  407.         constant [0] := 0X;
  408.         <*$ > *>
  409.         conx := 1
  410.       END;
  411.       x.a0 := conx - 1; x.label := OCT.ConstLabel
  412.     ELSIF x.a1 = 2 THEN
  413.       IF conx >= ConstLength - 1 THEN OCS.Mark (230); conx := 0 END;
  414.       <*$ < NilChk- IndexChk- *>
  415.       x.a0 := conx; constant [conx] := CHR (x.a2); INC (conx);
  416.       constant [conx] := 0X; INC (conx); x.label := OCT.ConstLabel
  417.       <*$ > *>
  418.     END;
  419.     IF x.obj # NIL THEN x.obj.a0 := x.a0; x.obj.label := x.label END
  420.   END
  421. END AllocStringFromChar;
  422.  
  423. (*------------------------------------*)
  424. PROCEDURE ConcatString *
  425.   (VAR s : ARRAY OF CHAR; len : LONGINT; VAR x : OCT.Item);
  426.  
  427.   VAR i, newLen : LONGINT;
  428.  
  429. BEGIN (* ConcatString *)
  430.   IF len > 0 THEN
  431.     newLen := len + x.a1 - 1;
  432.     IF len + x.a1 = 2 THEN
  433.       x.a1 := 2; x.a2 := ORD (s [0])
  434.     ELSIF x.a1 = 1 THEN
  435.       AllocString (s, len, x)
  436.     ELSE
  437.       IF x.a1 = 2 THEN AllocStringFromChar (x) END;
  438.       i := 0; DEC (conx);
  439.       IF (conx + len) >= ConstLength THEN OCS.Mark (230); conx := 0 END;
  440.       REPEAT
  441.         <*$ < NilChk- IndexChk- *>
  442.         constant [conx] := s [i]; INC (i); INC (conx)
  443.         <*$ > *>
  444.       UNTIL i = len + 1;
  445.       INC (x.a1, len)
  446.     END
  447.   END
  448. END ConcatString;
  449.  
  450. (*------------------------------------*)
  451. PROCEDURE AllocTypDesc * (typ : OCT.Struct);
  452.  
  453.   VAR t : INTEGER;
  454.  
  455. BEGIN (* AllocTypDesc *)
  456.   IF typ.form = Pointer THEN
  457.     t := 0;
  458.     WHILE t < typex DO
  459.       IF (type [t].form = Pointer) & (type [t].size = typ.size) THEN
  460.         typ.adr := t; typ.mno := 0; typ.label := type [t].label;
  461.         RETURN
  462.       END;
  463.       INC (t)
  464.     END
  465.   END;
  466.   IF typex >= NumTypes THEN OCS.Mark (233); typex := 0 END;
  467.   type [typex] := typ; typ.adr := typex; INC (typex);
  468.   typ.mno := 0; OCT.MakeTypeLabel (typ)
  469. END AllocTypDesc;
  470.  
  471. (*------------------------------------*)
  472. PROCEDURE GetDReg * (VAR x : OCT.Item; obj : OCT.Object);
  473.  
  474.   VAR r, reg : INTEGER;
  475.  
  476. BEGIN (* GetDReg *)
  477.   IF obj = wasderef THEN obj := NIL END;
  478.   x.mode := Reg; x.obj := NIL; x.a0 := D0;
  479.   reg := -1;
  480.  
  481.   (*
  482.   IF obj # NIL THEN
  483.     r := D7;
  484.     LOOP
  485.       IF regState.obj[r] = obj THEN reg := r; EXIT END;
  486.       DEC (r); IF r < D3 THEN EXIT END;
  487.     END
  488.   END;
  489.  
  490.   IF reg < 0 THEN
  491.     r := D7;
  492.     LOOP
  493.       IF ~(r IN regState.regs) & (regState.obj[r] = NIL) THEN
  494.         reg := r; EXIT
  495.       END;
  496.       DEC (r); IF r < D3 THEN EXIT END;
  497.     END
  498.   END;
  499.   *)
  500.  
  501.   IF reg < 0 THEN
  502.     r := D7;
  503.     LOOP
  504.       IF ~(r IN regState.regs) THEN reg := r; EXIT END;
  505.       DEC (r); IF r < D3 THEN EXIT END;
  506.     END
  507.   END;
  508.  
  509.   IF reg < 0  THEN
  510.     OCS.Mark (215)
  511.   ELSE
  512.     x.a0 := reg; INCL (regState.regs, reg); (*regState.obj[reg] := obj;*)
  513.     INC (regState.count[reg])
  514.   END
  515. END GetDReg;
  516.  
  517. (*------------------------------------*)
  518. PROCEDURE GetAReg * (VAR x : OCT.Item; obj : OCT.Object);
  519.  
  520.   VAR r, reg : INTEGER;
  521.  
  522. BEGIN (* GetAReg *)
  523.   IF obj = wasderef THEN obj := NIL END;
  524.   x.mode := Reg; x.obj := NIL; x.a0 := A5;
  525.   reg := -1;
  526.  
  527.   IF obj # NIL THEN
  528.     r := A6;
  529.     LOOP
  530.       IF regState.obj[r] = obj THEN reg := r; EXIT END;
  531.       DEC (r); IF r < A0 THEN EXIT END;
  532.     END
  533.   END;
  534.  
  535.   IF reg < 0 THEN
  536.     r := A3;
  537.     LOOP
  538.       IF ~(r IN regState.regs) & (regState.obj[r] = NIL) THEN
  539.         reg := r; EXIT
  540.       END;
  541.       DEC (r); IF r < A0 THEN EXIT END;
  542.     END;
  543.   END;
  544.  
  545.   IF reg < 0 THEN
  546.     IF ~(A6 IN regState.regs) & (regState.obj[A6] = NIL) THEN
  547.       reg := A6;
  548.     END;
  549.   END;
  550.  
  551.   IF reg < 0 THEN
  552.     r := A3;
  553.     LOOP
  554.       IF ~(r IN regState.regs) THEN reg := r; EXIT END;
  555.       DEC (r); IF r < A0 THEN EXIT END;
  556.     END;
  557.   END;
  558.  
  559.   IF reg < 0 THEN
  560.     IF ~(A6 IN regState.regs) THEN reg := A6 END;
  561.   END;
  562.  
  563.   IF reg < 0 THEN
  564.     OCS.Mark (215)
  565.   ELSE
  566.     x.a0 := reg; INCL (regState.regs, reg); regState.obj[reg] := obj;
  567.     INC (regState.count[reg])
  568.   END;
  569. END GetAReg;
  570.  
  571. (*------------------------------------*)
  572. PROCEDURE GetAnyReg * (VAR x : OCT.Item; obj : OCT.Object);
  573.  
  574.   VAR r, reg : INTEGER;
  575.  
  576. BEGIN (* GetAnyReg *)
  577.   IF obj = wasderef THEN obj := NIL END;
  578.   x.mode := Reg; x.obj := NIL; x.a0 := D0;
  579.   reg := -1;
  580.  
  581.   IF obj # NIL THEN
  582.     r := A6;
  583.     LOOP
  584.       IF regState.obj[r] = obj THEN reg := r; EXIT END;
  585.       (* DEC (r); IF r < D3 THEN EXIT END; *)
  586.       DEC (r); IF r < A0 THEN EXIT END;
  587.     END
  588.   END;
  589.  
  590.   (*
  591.   IF reg < 0 THEN
  592.     r := D7;
  593.     LOOP
  594.       IF ~(r IN regState.regs) & (regState.obj[r] = NIL) THEN
  595.         reg := r; EXIT
  596.       END;
  597.       DEC (r); IF r < D3 THEN EXIT END;
  598.     END;
  599.   END;
  600.   *)
  601.  
  602.   IF reg < 0 THEN
  603.     r := A3;
  604.     LOOP
  605.       IF ~(r IN regState.regs) & (regState.obj[r] = NIL) THEN
  606.         reg := r; EXIT
  607.       END;
  608.       DEC (r); IF r < A0 THEN EXIT END;
  609.     END;
  610.   END;
  611.  
  612.   IF reg < 0 THEN
  613.     r := D7;
  614.     LOOP
  615.       IF ~(r IN regState.regs) THEN reg := r; EXIT END;
  616.       DEC (r); IF r < D3 THEN EXIT END;
  617.     END;
  618.   END;
  619.  
  620.   IF reg < 0 THEN
  621.     r := A3;
  622.     LOOP
  623.       IF ~(r IN regState.regs) THEN reg := r; EXIT END;
  624.       DEC (r); IF r < A0 THEN EXIT END;
  625.     END;
  626.   END;
  627.  
  628.   IF reg < 0 THEN
  629.     IF ~(A6 IN regState.regs) THEN reg := A6 END;
  630.   END;
  631.  
  632.   IF reg < 0 THEN
  633.     OCS.Mark (215)
  634.   ELSE
  635.     x.a0 := reg; INCL (regState.regs, reg); regState.obj[reg] := obj;
  636.     INC (regState.count[reg])
  637.   END;
  638. END GetAnyReg;
  639.  
  640. (*------------------------------------*)
  641. PROCEDURE ReserveReg * (reg : LONGINT; obj : OCT.Object);
  642.  
  643. BEGIN (* ReserveReg *)
  644.   IF ~(reg IN regState.regs) THEN
  645.     INCL (regState.regs, reg);
  646.     IF reg IN AdrRegs THEN regState.obj[reg] := obj END;
  647.     regState.count[reg] := 1
  648.   ELSE
  649.     OCS.Mark (215)
  650.   END;
  651. END ReserveReg;
  652.  
  653. (*------------------------------------*)
  654. PROCEDURE UnReserveReg * (reg : LONGINT);
  655.  
  656. BEGIN (* UnReserveReg *)
  657.   IF (reg IN regState.regs) & (regState.count[reg] = 1) THEN
  658.     regState.count[reg] := 0;
  659.     EXCL (regState.regs, reg);
  660.   ELSE OCS.Mark (951)
  661.   END;
  662. END UnReserveReg;
  663.  
  664. (*------------------------------------*)
  665. PROCEDURE FreeRegs * (VAR r : RegState);
  666.  
  667.   VAR reg : INTEGER;
  668.  
  669. BEGIN (* FreeRegs *)
  670.   regState.regs := r.regs;
  671.   FOR reg := 0 TO 15 DO
  672.     IF ~(reg IN regState.regs) THEN regState.count[reg] := 0 END
  673.   END
  674. END FreeRegs;
  675.  
  676. (*------------------------------------*)
  677. PROCEDURE FreeReg * (VAR x : OCT.Item);
  678.  
  679.   VAR R : SET; r : LONGINT;
  680.  
  681. BEGIN (* FreeReg *)
  682.   IF x.mode IN {Reg, RegI, RegX, Push, Pop} THEN
  683.     r := x.a0;
  684.     IF (r IN regState.regs) & (regState.count[r] > 0) THEN
  685.       DEC (regState.count[r]);
  686.       IF regState.count[r] = 0 THEN EXCL (regState.regs, r) END
  687.     ELSE OCS.Mark (951)
  688.     END;
  689.     IF x.mode = RegX THEN
  690.       r := x.a2;
  691.       IF (r IN regState.regs) & (regState.count[r] > 0) THEN
  692.         DEC (regState.count[r]);
  693.         IF regState.count[r] = 0 THEN EXCL (regState.regs, r) END
  694.       ELSE OCS.Mark (951)
  695.       END
  696.     END
  697.   ELSIF x.mode IN {VarX, IndX} THEN
  698.     r := x.a2;
  699.     IF (r IN regState.regs) & (regState.count[r] > 0) THEN
  700.       DEC (regState.count[r]);
  701.       IF regState.count[r] = 0 THEN EXCL (regState.regs, r) END
  702.     ELSE OCS.Mark (951)
  703.     END
  704.   ELSIF x.mode = RList THEN
  705.     R := SYS.VAL (SET, x.a0);
  706.     IF (R * regState.regs) = R THEN
  707.       regState.regs := regState.regs - R;
  708.       FOR r := 0 TO 15 DO IF r IN R THEN regState.count[r] := 0 END END
  709.     ELSE OCS.Mark (951)
  710.     END
  711.   ELSE OCS.Mark (216)
  712.   END;
  713.   x.mode := Undef
  714. END FreeReg;
  715.  
  716. (*------------------------------------*)
  717. PROCEDURE InDataReg* ( obj : OCT.Object ) : BOOLEAN;
  718.  
  719.   VAR i : INTEGER;
  720.  
  721. BEGIN (* InDataReg *)
  722.   IF obj = wasderef THEN obj := NIL END;
  723.   IF obj # NIL THEN
  724.     FOR i := D0 TO D7 DO IF regState.obj[i] = obj THEN RETURN TRUE END END
  725.   END;
  726.   RETURN FALSE
  727. END InDataReg;
  728.  
  729. (*------------------------------------*)
  730. PROCEDURE InAdrReg* ( obj : OCT.Object ) : BOOLEAN;
  731.  
  732.   VAR i : INTEGER;
  733.  
  734. BEGIN (* InAdrReg *)
  735.   IF obj = wasderef THEN obj := NIL END;
  736.   IF obj # NIL THEN
  737.     FOR i := A0 TO A6 DO IF regState.obj[i] = obj THEN RETURN TRUE END END
  738.   END;
  739.   RETURN FALSE
  740. END InAdrReg;
  741.  
  742. (*------------------------------------*)
  743. PROCEDURE RememberReg* ( VAR x : OCT.Item; obj : OCT.Object );
  744. BEGIN (* RememberReg *)
  745.   IF obj = wasderef THEN obj := NIL END;
  746.   IF obj # NIL THEN
  747.     IF (x.mode = Reg) & (x.a0 IN AdrRegs) THEN
  748.       regState.obj[x.a0] := obj
  749.     END
  750.   END;
  751. END RememberReg;
  752.  
  753. (*------------------------------------*)
  754. PROCEDURE ForgetReg* ( reg : LONGINT );
  755. BEGIN (* ForgetReg *)
  756.   regState.obj[reg] := NIL
  757. END ForgetReg;
  758.  
  759. (*------------------------------------*)
  760. PROCEDURE ForgetObj* ( obj : OCT.Object );
  761.  
  762.   VAR r : INTEGER;
  763.  
  764. BEGIN (* ForgetObj *)
  765.   IF obj = wasderef THEN obj := NIL END;
  766.   IF obj # NIL THEN
  767.     FOR r := D0 TO A6 DO
  768.       IF regState.obj[r] = obj THEN regState.obj[r] := NIL; RETURN END
  769.     END;
  770.   END;
  771. END ForgetObj;
  772.  
  773. (*------------------------------------*)
  774. PROCEDURE ForgetRegs*;
  775.  
  776.   VAR r : INTEGER;
  777.  
  778. BEGIN (* ForgetRegs *)
  779.   FOR r := D0 TO A6 DO regState.obj[r] := NIL END
  780. END ForgetRegs;
  781.  
  782. (*------------------------------------*)
  783. PROCEDURE PutWord * (w : LONGINT);
  784.  
  785. BEGIN (* PutWord *)
  786.   IF (w < MIN (INTEGER)) OR (w > 65535) THEN OCS.Mark (958) END;
  787.   IF genCode THEN
  788.     IF codex >= CodeLength THEN OCS.Mark (231); codex := 0; pc := 0 END;
  789.     <*$ < NilChk- IndexChk- RangeChk- *>
  790.     code [codex] := SHORT (w);
  791.     <*$ > *>
  792.     INC (codex); INC (pc, 2)
  793.   END;
  794. END PutWord;
  795.  
  796. (*------------------------------------*)
  797. PROCEDURE PatchWord * (loc, w : LONGINT);
  798.  
  799. BEGIN (* PatchWord *)
  800.   IF (w < MIN (INTEGER)) OR (w > 65535) THEN OCS.Mark (958) END;
  801.   IF genCode THEN
  802.     IF loc >= pc THEN OCS.Mark (961); loc := 0 END;
  803.     loc := loc DIV 2;
  804.     <*$ < NilChk- IndexChk- RangeChk- *>
  805.     code [loc] := SYS.LOR (code [loc], SHORT (w))
  806.     <*$ > *>
  807.   END;
  808. END PatchWord;
  809.  
  810. (*------------------------------------*)
  811. PROCEDURE PutLong * (l : LONGINT);
  812.  
  813. BEGIN (* PutLong *)
  814.   IF codex >= CodeLength - 1 THEN OCS.Mark (231); codex := 0; pc := 0 END;
  815.   IF genCode THEN
  816.     <*$ < NilChk- IndexChk- RangeChk- *>
  817.     code [codex] := SHORT (l DIV 10000H); INC (codex);
  818.     code [codex] := SHORT (l MOD 10000H); INC (codex);
  819.     <*$ > *>
  820.     INC (pc, 4)
  821.   END;
  822. END PutLong;
  823.  
  824. (*------------------------------------*)
  825. PROCEDURE FindRef (label : OCT.Label; type : LONGINT) : Ref;
  826.  
  827.   VAR ref : Ref;
  828.  
  829. BEGIN (* FindRef *)
  830.   ref := CurrCodeHunk.refs;
  831.   WHILE (ref # NIL) & ((ref.label^ # label^) OR (ref.type # type)) DO
  832.     ref := ref.next
  833.   END;
  834.   RETURN ref
  835. END FindRef;
  836.  
  837. (*------------------------------------*)
  838. PROCEDURE MakeRef (ref : Ref; label : OCT.Label; type : INTEGER);
  839.  
  840.   VAR offset : Offset;
  841.  
  842. BEGIN (* MakeRef *)
  843.   IF genCode THEN
  844.     IF ref = NIL THEN
  845.       NEW (ref);
  846.       ref.next := CurrCodeHunk.refs; CurrCodeHunk.refs := ref;
  847.       ref.type := type; ref.label := label; ref.count := 0;
  848.       ref.offsets := NIL;
  849.     END;
  850.  
  851.     NEW (offset);
  852.     offset.next := ref.offsets; ref.offsets := offset; INC (ref.count);
  853.     offset.n := pc - (CurrCodeHunk.start * 2);
  854.   END;
  855. END MakeRef;
  856.  
  857. (*------------------------------------*)
  858. PROCEDURE PutWordRef * (offset : INTEGER; label : OCT.Label);
  859.  
  860. BEGIN (* PutWordRef *)
  861.   IF label # NIL THEN
  862.     MakeRef (FindRef (label, wordRef), label, wordRef); PutWord (offset)
  863.   ELSE
  864.     OCS.Mark (964)
  865.   END
  866. END PutWordRef;
  867.  
  868. (*------------------------------------*)
  869. PROCEDURE PutLongRef * (offset : LONGINT; label : OCT.Label);
  870.  
  871. BEGIN (* PutLongRef *)
  872.   IF label # NIL THEN
  873.     MakeRef (FindRef (label, longRef), label, longRef); PutLong (offset)
  874.   ELSE
  875.     OCS.Mark (964)
  876.   END
  877. END PutLongRef;
  878.  
  879. (*------------------------------------*)
  880. PROCEDURE PutSmallRef * (offset : INTEGER; label : OCT.Label);
  881.  
  882. BEGIN (* PutSmallRef *)
  883.   IF label # NIL THEN
  884.     MakeRef (FindRef (label, smallRef), label, smallRef); PutWord (offset)
  885.   ELSE
  886.     OCS.Mark (964)
  887.   END
  888. END PutSmallRef;
  889.  
  890. (*------------------------------------*)
  891. PROCEDURE PutArg (VAR arg : Arg);
  892.  
  893. BEGIN (* PutArg *)
  894.   CASE arg.form OF
  895.     none :
  896.     |
  897.     word :
  898.       PutWord (arg.data)
  899.     |
  900.     long :
  901.       PutLong (arg.data)
  902.     |
  903.     wordRef, longRef, smallRef :
  904.       MakeRef (FindRef (arg.label, arg.form), arg.label, arg.form);
  905.       IF arg.form = longRef THEN PutLong (arg.data)
  906.       ELSE PutWord (arg.data)
  907.       END
  908.   ELSE
  909.     OCS.Mark (1008)
  910.   END;
  911. END PutArg;
  912.  
  913. (*------------------------------------*)
  914. PROCEDURE Argument
  915.   ( VAR op : LONGINT; size : LONGINT; ea05 : BOOLEAN;
  916.     VAR item : OCT.Item; VAR arg : Arg );
  917.  
  918.   VAR
  919.     form, mode, itemMode : INTEGER; reg, op2 : LONGINT;
  920.     regItem : OCT.Item; data : LONGINT; label : OCT.Label;
  921.  
  922.   (*------------------------------------*)
  923.   PROCEDURE downlevel ();
  924.  
  925.     VAR diff : INTEGER; op : LONGINT;
  926.  
  927.   BEGIN (* downlevel *)
  928.     diff := level - item.lev;
  929.     GetAReg (regItem, NIL); reg := regItem.a0-8;
  930.  
  931.     op := 206DH + SYS.LSH (reg, 9);          (* MOVEA.L 8(A5), An *)
  932.     PutWord (op); PutWord (8);
  933.  
  934.     op := 2068H + SYS.LSH (reg, 9) + reg;    (* MOVEA.L 8(An), An *)
  935.     WHILE diff > 1 DO
  936.       PutWord (op); PutWord (8);
  937.       DEC (diff)
  938.     END;
  939.  
  940.     mode := ARDisp; form := word; data := item.a0
  941.   END downlevel;
  942.  
  943. BEGIN (* Argument *)
  944.   form := none;
  945.   CASE item.mode OF
  946.     Var, VarX, Ind, IndX :
  947.       itemMode := item.mode;
  948.       IF (OCM.SmallData OR OCM.Resident) & (item.lev <= 0) THEN
  949.                                    (* Global variable in small data model *)
  950.         IF A4 IN regState.regs THEN OCS.Mark (235) END;
  951.         mode := ARDisp; reg := BP; form := smallRef; data := item.a0;
  952.         IF item.lev = 0 THEN label := OCT.VarLabel
  953.         ELSE label := OCT.GlbMod [-item.lev-1].varLab
  954.         END
  955.       ELSIF item.lev = 0 THEN          (* Global variable of local module *)
  956.         IF OCS.pragma [OCS.longVars] OR (item.a0 > 32767)
  957.         OR (A4 IN regState.regs)
  958.         THEN
  959.           mode := Mode7; reg := AbsL; form := longRef;
  960.           label := OCT.VarLabel; data := item.a0
  961.         ELSIF item.a0 = 0 THEN
  962.           mode := ARInd; reg := BP; form := none
  963.         ELSE
  964.           mode := ARDisp; reg := BP; form := word; data := item.a0
  965.         END
  966.       ELSIF item.lev < 0 THEN       (* Global variable of imported module *)
  967.         mode := Mode7; reg := AbsL; form := longRef;
  968.         label := OCT.GlbMod [-item.lev-1].varLab; data := item.a0
  969.       ELSIF item.lev = level THEN          (* Local variable in procedure *)
  970.         IF item.a0 = 0 THEN
  971.           mode := ARInd; reg := FP; form := none
  972.         ELSE
  973.           mode := ARDisp; reg := FP; form := word; data := item.a0
  974.         END
  975.       ELSE                       (* Local variable in surrounding context *)
  976.         downlevel ();
  977.         IF itemMode = Var THEN
  978.           item.mode := RegI; item.a1 := item.a0; item.a0 := reg + 8;
  979.           item.obj := NIL;
  980.           Argument (op, size, ea05, item, arg);
  981.           RETURN
  982.         END
  983.       END;
  984.  
  985.       arg.form := form; arg.data := data; arg.label := label;
  986.       IF itemMode = VarX THEN
  987.         GetAReg (regItem, NIL);
  988.         op2 :=
  989.           LEA + SYS.LSH (mode, 3) + reg
  990.           + SYS.LSH (regItem.a0-8, 9);                  (* LEA <item>, An *)
  991.         PutWord (op2); PutArg (arg);
  992.         item.mode := RegX; item.a0 := regItem.a0; item.a1 := 0;
  993.         item.obj := NIL;
  994.         Argument (op, size, ea05, item, arg);
  995.         RETURN
  996.       ELSIF itemMode # Var THEN
  997.         GetAReg (regItem, NIL);
  998.         op2 :=
  999.           2040H + SYS.LSH (mode, 3) + reg
  1000.           + SYS.LSH (regItem.a0 - 8, 9);
  1001.         PutWord (op2); PutArg (arg);               (* MOVEA.L, <item>, An *)
  1002.         reg := regItem.a0 - 8;
  1003.         IF itemMode = IndX THEN item.mode := RegX
  1004.         ELSE item.mode := RegI
  1005.         END;
  1006.         item.a0 := regItem.a0; item.obj := NIL;
  1007.         Argument (op, size, ea05, item, arg);
  1008.         RETURN
  1009.       END
  1010.     |
  1011.     VarR :
  1012.       label := NIL; data := 0;
  1013.       IF item.a0 < A0 THEN form := DReg; reg := item.a0
  1014.       ELSE form := ARDir; reg := item.a0 - 8
  1015.       END;
  1016.       item.mode := Reg; item.a1 := 0
  1017.     |
  1018.     IndR :
  1019.       label := NIL; data := 0;
  1020.       IF item.a0 < A0 THEN
  1021.         reg := item.a0; GetAReg (regItem, NIL);
  1022.         op2 :=
  1023.           2040H + SYS.LSH (mode, 3) + reg
  1024.           + SYS.LSH (regItem.a0 - 8, 9);
  1025.         PutWord (op2); PutArg (arg);              (* MOVEA.L, <item>, An *)
  1026.         form := ARInd; reg := regItem.a0 - 8;
  1027.         item.mode := RegI; item.a0 := regItem.a0; item.a1 := 0
  1028.       ELSE
  1029.         form := ARInd; reg := item.a0 - 8;
  1030.         item.mode := RegI; item.a1 := 0
  1031.       END
  1032.     |
  1033.     RegI :
  1034.       IF ~(item.a0 IN AdrRegs) THEN OCS.Mark (215); item.a0 := A0 END;
  1035.       reg := item.a0 - 8;
  1036.       IF item.a1 = 0 THEN mode := ARInd; form := none
  1037.       ELSIF (item.a1 < -32768) OR (item.a1 > 32767) THEN
  1038.         GetAnyReg (regItem, NIL);
  1039.         IF regItem.a0 < A0 THEN                     (* MOVE.L #offset, Dn *)
  1040.           op2 := 203CH + SYS.LSH (regItem.a0, 9)
  1041.         ELSE                                       (* MOVEA.L #offset, An *)
  1042.           op2 := 207CH + SYS.LSH (regItem.a0 - 8, 9)
  1043.         END;
  1044.         PutWord (op2); PutLong (item.a1);
  1045.         item.mode := RegX; item.a1 := 0; item.a2 := regItem.a0;
  1046.         item.wordIndex := FALSE;
  1047.         Argument (op, size, ea05, item, arg);
  1048.         RETURN
  1049.       ELSE
  1050.         mode := ARDisp; form := word; data := item.a1
  1051.       END
  1052.     |
  1053.     RegX :
  1054.       IF ~(item.a0 IN AdrRegs) THEN OCS.Mark (215); item.a0 := A0 END;
  1055.       mode := ARDisX; reg := item.a0 - 8;
  1056.       IF (item.a1 < -128) OR (item.a1 > 127) THEN
  1057.         IF item.a2 < A0 THEN                        (* ADDI.z #offset, Rn *)
  1058.           IF item.wordIndex THEN op2 := 0640H + item.a2
  1059.           ELSE op2 := 0680H + item.a2
  1060.           END
  1061.         ELSE                                        (* ADDA.Z #offset, Rn *)
  1062.           IF item.wordIndex THEN op2 := 0D0FCH
  1063.           ELSE op2 := 0D1FCH
  1064.           END;
  1065.           op2 := op2 + SYS.LSH (item.a2 - 8, 9)
  1066.         END;
  1067.         PutWord (op2);
  1068.         IF item.wordIndex THEN PutWord (item.a1)
  1069.         ELSE PutLong (item.a1)
  1070.         END;
  1071.         item.a1 := 0
  1072.       END;
  1073.       form := word;
  1074.       data := SYS.AND (item.a1, 0FFH);                    (* Displacement *)
  1075.       data := SYS.LOR (data, SYS.LSH (item.a2 MOD 8, 12));
  1076.                                                             (* Index reg. *)
  1077.       IF item.a2 >= A0 THEN data := SYS.LOR (data, 8000H)
  1078.       END;                                                  (* Addr. Reg. *)
  1079.       IF ~item.wordIndex THEN data := SYS.LOR (data, 800H)   (* Long reg. *)
  1080.       END;
  1081.     |
  1082.     Lab, LabI :
  1083.       mode := Mode7;
  1084.       IF item.mode = Lab THEN reg := AbsL ELSE reg := Imm END;
  1085.       IF item.a1 = W THEN form := wordRef
  1086.       ELSIF item.a1 = L THEN form := longRef
  1087.       ELSE OCS.Mark (957); form := longRef
  1088.       END;
  1089.       data := item.a0; label := item.label
  1090.     |
  1091.     Abs :
  1092.       mode := Mode7;
  1093.       IF (-32768 <= item.a0) & (item.a0 <= 32767) THEN
  1094.         reg := AbsW; form := word
  1095.       ELSE
  1096.         reg := AbsL; form := long
  1097.       END;
  1098.       data := item.a0
  1099.     |
  1100.     Con :
  1101.       IF (item.typ = OCT.stringtyp) OR (item.typ = OCT.tagtyp) THEN
  1102.         IF item.a0 < 0 THEN OCS.Mark (962) END;
  1103.         IF OCM.SmallData THEN
  1104.           IF A4 IN regState.regs THEN OCS.Mark (235) END;
  1105.           mode := ARDisp; reg := BP; form := smallRef; data := item.a0;
  1106.         ELSE
  1107.           mode := Mode7; reg := AbsL; form := longRef; data := item.a0;
  1108.         END;
  1109.         label := item.label
  1110.       ELSE
  1111.         mode := Mode7; reg := Imm;
  1112.         IF size < L THEN form := word ELSE form := long END;
  1113.         data := item.a0
  1114.       END
  1115.     |
  1116.     Push, Pop :
  1117.       IF ~(item.a0 IN AdrRegs) THEN OCS.Mark (215); item.a0 := A0 END;
  1118.       IF item.mode = Push THEN mode := ARPre ELSE mode := ARPost END;
  1119.       reg := item.a0 - 8; form := none
  1120.     |
  1121.     Reg :
  1122.       IF item.a0 IN DataRegs THEN
  1123.         mode := DReg; reg := item.a0; form := none
  1124.       ELSE
  1125.         mode := ARDir; reg := item.a0 - 8; form := none
  1126.       END
  1127.     |
  1128.     XProc, LProc, CallBack :
  1129.       mode := Mode7; data := 0; label := item.obj.label;
  1130.       IF item.lev < 0 THEN reg := AbsL; form := longRef (* Imported proc. *)
  1131.       ELSE reg := AbsW; form := wordRef
  1132.       END
  1133.     |
  1134.     M2Proc, CProc, AProc :
  1135.       mode := Mode7; data := 0; label := item.obj.label;
  1136.       reg := AbsL; form := longRef
  1137.     |
  1138.     RList :
  1139.       arg.form := word; arg.data := item.a0;
  1140.       RETURN
  1141.     |
  1142.   ELSE
  1143.     form := none; OCS.Mark (126);
  1144.     RETURN
  1145.   END; (* CASE item.mode *)
  1146.  
  1147.   arg.form := form; arg.data := data; arg.label := label;
  1148.   IF ea05 THEN op := op + SYS.LSH (mode, 3) + reg
  1149.   ELSE op := op + SYS.LSH (mode, 6) + SYS.LSH (reg, 9)
  1150.   END
  1151. END Argument;
  1152.  
  1153. (*------------------------------------*)
  1154. PROCEDURE PutF1 * (op : LONGINT; size : LONGINT; VAR item : OCT.Item);
  1155. (*
  1156.   Instruction format #1: xxxxxxxxsseeeeee
  1157.  
  1158.   Instructions: CLR, NEG, NOT, TST
  1159. *)
  1160.  
  1161.   VAR arg : Arg;
  1162.  
  1163. BEGIN (* PutF1 *)
  1164.   op := op + SYS.LSH ((size DIV 2), 6);
  1165.   Argument (op, size, TRUE, item, arg);
  1166.   PutWord (op); PutArg (arg)
  1167. END PutF1;
  1168.  
  1169. (*------------------------------------*)
  1170. PROCEDURE PutF2 * (op : LONGINT; VAR src : OCT.Item; reg : LONGINT);
  1171. (*
  1172.   Instruction format #2: xxxxrrrxxxeeeeee
  1173.  
  1174.   Instructions: LEA, DIVS, MULS, CHK
  1175. *)
  1176.  
  1177.   VAR arg : Arg;
  1178.  
  1179. BEGIN (* PutF2 *)
  1180.   op := op + SYS.LSH (reg MOD 8, 9);
  1181.   Argument (op, W, TRUE, src, arg);
  1182.   PutWord (op); PutArg (arg)
  1183. END PutF2;
  1184.  
  1185. (*------------------------------------*)
  1186. PROCEDURE PutF3 * (op : LONGINT; VAR item : OCT.Item);
  1187.  
  1188. (*
  1189.   Instruction format #3: xxxxxxxxxxeeeeee
  1190.  
  1191.   Instructions: PEA, JSR, JMP, Scc
  1192. *)
  1193.  
  1194.   VAR arg : Arg;
  1195.  
  1196. BEGIN (* PutF3 *)
  1197.   Argument (op, W, TRUE, item, arg);
  1198.   PutWord (op); PutArg (arg)
  1199. END PutF3;
  1200.  
  1201. (*------------------------------------*)
  1202. PROCEDURE Bit * (op : LONGINT; VAR src, dst : OCT.Item);
  1203.  
  1204. (*
  1205.   Instruction format #2: xxxxrrrxxxeeeeee
  1206.   Instruction format #3: xxxxxxxxxxeeeeee
  1207.  
  1208.   Instructions: BTST, BCLR, BSET
  1209. *)
  1210.  
  1211.   VAR arg : Arg;
  1212.  
  1213. BEGIN (* Bit *)
  1214.   IF src.mode = Reg THEN
  1215.     op := SYS.LOR (op, SYS.LOR (100H, SYS.LSH (src.a0, 9)))
  1216.   ELSE
  1217.     op := SYS.LOR (op, 800H)
  1218.   END;
  1219.   Argument (op, W, TRUE, dst, arg);
  1220.   PutWord (op); IF src.mode = Con THEN PutWord (src.a0) END;
  1221.   PutArg (arg)
  1222. END Bit;
  1223.  
  1224. (*------------------------------------*)
  1225. PROCEDURE Move * (size : LONGINT; VAR src, dst : OCT.Item);
  1226.  
  1227.   VAR arg1, arg2 : Arg; op, reg : LONGINT; rlist1, rlist2 : SET;
  1228.  
  1229. BEGIN (* Move *)
  1230.   IF (src.mode = Reg) & (dst.mode = Reg) & (src.a0 = dst.a0) THEN
  1231.     RETURN
  1232.   END;
  1233.   IF src.mode = RList THEN                       (* MOVEM Registers to EA *)
  1234.     IF size = L THEN op := 48C0H ELSE op := 4880H END;
  1235.     Argument (op, size, TRUE, dst, arg1);
  1236.     IF dst.mode = Push THEN
  1237.       (* Reverse the register list first *)
  1238.       reg := 0;
  1239.       rlist1 := SYS.VAL (SET, src.a0); rlist2 := {};
  1240.       WHILE reg <= A7 DO
  1241.         IF reg IN rlist1 THEN INCL (rlist2, 15 - reg) END;
  1242.         INC (reg)
  1243.       END;
  1244.       src.a0 := SYS.VAL (LONGINT, rlist2)
  1245.     END;
  1246.     PutWord (op); PutWord (src.a0); PutArg (arg1)
  1247.   ELSIF dst.mode = RList THEN                    (* MOVEM EA to Registers *)
  1248.     IF size = L THEN op := 4CC0H ELSE op := 4C80H END;
  1249.     Argument (op, size, TRUE, src, arg1);
  1250.     PutWord (op); PutWord (dst.a0); PutArg (arg1)
  1251.   ELSIF (dst.mode = Reg) & (dst.a0 IN AdrRegs) THEN
  1252.     IF (src.mode = Con) & (src.a0 = 0) THEN        (* SUBA.Z <dst>, <dst> *)
  1253.       reg := dst.a0 - 8; op := 90C8H;
  1254.       IF size = L THEN op := SYS.LOR (op, 100H)
  1255.       ELSIF size = B THEN OCS.Mark (957)
  1256.       END;
  1257.       op := SYS.LOR (op, SYS.LOR (SYS.LSH (reg, 9), reg));
  1258.       PutWord (op)
  1259.     ELSE                                          (* MOVEA.Z <src>, <dst> *)
  1260.       IF size = L THEN
  1261.         op := SYS.LOR (2040H, SYS.LSH (dst.a0 MOD 8, 9))
  1262.       ELSIF size = W THEN
  1263.         op := SYS.LOR (3040H, SYS.LSH (dst.a0 MOD 8, 9))
  1264.       ELSE
  1265.         OCS.Mark (957); op := 3040H
  1266.       END;
  1267.       Argument (op, size, TRUE, src, arg1); PutWord (op); PutArg (arg1)
  1268.     END
  1269.   ELSIF
  1270.     (dst.mode = Reg) & (dst.a0 IN DataRegs) & (src.mode = Con)
  1271.     & (src.a0 >= -128) & (src.a0 <= 127)
  1272.   THEN                                             (* MOVEQ #<src>, <dst> *)
  1273.     op := SYS.LOR (7000H, SYS.LSH (dst.a0, 9));
  1274.     op := SYS.LOR (op, SYS.AND (src.a0, 0FFH));
  1275.     PutWord (op)
  1276.   ELSIF (src.mode = Con) & (src.a0 = 0) THEN               (* CLR.z <dst> *)
  1277.     PutF1 (CLR, size, dst)
  1278.   ELSE                                             (* MOVE.z <src>, <dst> *)
  1279.     IF size = L THEN op := 2000H
  1280.     ELSIF size = W THEN op := 3000H
  1281.     ELSIF size = B THEN op := 1000H
  1282.     ELSE
  1283.       OCS.Mark (957); op := 1000H
  1284.     END;
  1285.     Argument (op, size, TRUE, src, arg1);
  1286.     Argument (op, size, FALSE, dst, arg2);
  1287.     PutWord (op); PutArg (arg1); PutArg (arg2)
  1288.   END
  1289. END Move;
  1290.  
  1291. (*------------------------------------*)
  1292. PROCEDURE PutF7 * (op : LONGINT; size, src : LONGINT; VAR dst : OCT.Item);
  1293. (*
  1294.   Instruction format #7: xxxxdddxsseeeeee
  1295.  
  1296.   Instructions: ADDQ, SUBQ
  1297. *)
  1298.  
  1299.   VAR arg : Arg;
  1300.  
  1301. BEGIN (* PutF7 *)
  1302.   IF (src > 0) & (src <= 8) THEN
  1303.     op := SYS.LOR (op, SYS.LSH ((size DIV 2), 6));
  1304.     op := SYS.LOR (op, SYS.LSH (src MOD 8, 9));
  1305.     Argument (op, size, TRUE, dst, arg); PutWord (op); PutArg (arg)
  1306.   ELSE
  1307.     OCS.Mark (957)
  1308.   END; (* ELSE *)
  1309. END PutF7;
  1310.  
  1311. (*------------------------------------*)
  1312. PROCEDURE PutF6 * (op, size : LONGINT; VAR src, dst : OCT.Item);
  1313. (*
  1314.   Instruction format #6: xxxxxxxxsseeeeee
  1315.  
  1316.   Instructions: ORI, SUBI, CMPI, EORI, ANDI, ADDI
  1317.   Instructions: ADDQ, SUBQ
  1318. *)
  1319.  
  1320.   VAR arg : Arg;
  1321.  
  1322. BEGIN (* PutF6 *)
  1323.   IF ((op = ADDI) OR (op = SUBI)) & (src.a0 > 0) & (src.a0 < 9) THEN
  1324.     IF op = ADDI THEN op := ADDQ ELSE op := SUBQ END;
  1325.     PutF7 (op, size, src.a0, dst)
  1326.   ELSE
  1327.     op := SYS.LOR (op, SYS.LSH ((size DIV 2), 6));
  1328.     Argument (op, size, TRUE, dst, arg); PutWord (op);
  1329.     IF src.mode = LabI THEN PutLongRef (src.a0, src.label)
  1330.     ELSIF size = L THEN PutLong (src.a0)
  1331.     ELSE PutWord (src.a0)
  1332.     END;
  1333.     PutArg (arg)
  1334.   END
  1335. END PutF6;
  1336.  
  1337. (*------------------------------------*)
  1338. PROCEDURE PutF5 * (op, size : LONGINT; VAR src, dst : OCT.Item);
  1339. (*
  1340.   Instruction format #5: xxxxrrrmmmeeeeee
  1341.  
  1342.   Instructions: OR, SUB, SUBA, CMP, CMPA, EOR, AND, ADD, ADDA, ORI,
  1343.   SUBI, CMPI, EORI, ANDI, ADDI, ADDQ, SUBQ
  1344. *)
  1345.  
  1346.   VAR arg : Arg;
  1347.  
  1348. BEGIN (* PutF5 *)
  1349.   IF (dst.mode = Reg) & (dst.a0 IN AdrRegs) THEN
  1350.     IF size = L THEN op := SYS.LOR (op, 1C0H)
  1351.     ELSIF size = W THEN op := SYS.LOR (op, 0C0H)
  1352.     ELSE OCS.Mark (957)
  1353.     END;
  1354.     op := SYS.LOR (op, SYS.LSH (dst.a0 - 8, 9));
  1355.     Argument (op, size, TRUE, src, arg)
  1356.   ELSIF (src.mode = Con) OR (src.mode = LabI) THEN
  1357.     IF op = iOR THEN op := ORI
  1358.     ELSIF op = SUB THEN op := SUBI
  1359.     ELSIF op = CMP THEN op := CMPI
  1360.     ELSIF op = EOR THEN op := EORI
  1361.     ELSIF op = AND THEN op := ANDI
  1362.     ELSIF op = ADD THEN op := ADDI
  1363.     ELSE OCS.Mark (956)
  1364.     END;
  1365.     PutF6 (op, size, src, dst);
  1366.     RETURN
  1367.   ELSIF (op # EOR) & (dst.mode = Reg) & (dst.a0 IN DataRegs) THEN
  1368.     op := SYS.LOR (op, SYS.LSH (size DIV 2, 6));
  1369.     op := SYS.LOR (op, SYS.LSH (dst.a0, 9));
  1370.     Argument (op, size, TRUE, src, arg)
  1371.   ELSE
  1372.     op := SYS.LOR (op, SYS.LSH (size DIV 2, 6));
  1373.     op := SYS.LOR (SYS.LOR (op, 100H), SYS.LSH (src.a0, 9));
  1374.     Argument (op, size, TRUE, dst, arg)
  1375.   END;
  1376.   PutWord (op); PutArg (arg)
  1377. END PutF5;
  1378.  
  1379. (*------------------------------------*)
  1380. PROCEDURE Shift * (op, size : LONGINT; VAR count, reg : OCT.Item);
  1381.  
  1382. (*
  1383.   Instruction format #5: xxxxrrrxssxxxrrr
  1384.  
  1385.   Instructions: ASL, ASR, LSL, LSR, ROL, ROR
  1386. *)
  1387.  
  1388.   VAR arg : Arg;
  1389.  
  1390. BEGIN (* Shift *)
  1391.   IF (reg.mode = Reg) & (reg.a0 IN DataRegs) THEN
  1392.     op := SYS.LOR (op, SYS.LSH ((size DIV 2), 6));
  1393.     op := SYS.LOR (op, reg.a0);
  1394.     IF (count.mode = Reg) & (count.a0 IN DataRegs) THEN
  1395.       op := SYS.LOR (op, 20H);
  1396.       op := SYS.LOR (op, SYS.LSH (count.a0, 9))
  1397.     ELSIF count.mode = Con THEN
  1398.       IF (count.a0 > 0) & (count.a0 <= 8) THEN
  1399.         op := SYS.LOR (op, SYS.LSH (count.a0 MOD 8, 9))
  1400.       ELSE OCS.Mark (957)
  1401.       END;
  1402.     ELSE OCS.Mark (956)
  1403.     END;
  1404.     PutWord (op)
  1405.   ELSE OCS.Mark (956)
  1406.   END;
  1407. END Shift;
  1408.  
  1409. (*------------------------------------*)
  1410. PROCEDURE SaveRegisters0 (regs : SET);
  1411.  
  1412.   VAR numRegs, reg, lastReg, op : INTEGER; rlist : SET;
  1413.  
  1414. BEGIN (* SaveRegisters0 *)
  1415.   IF regs # {} THEN
  1416.     numRegs := 0; reg := 0;
  1417.     WHILE reg <= A7 DO
  1418.       IF reg IN regs THEN lastReg := reg; INC (numRegs) END;
  1419.       INC (reg)
  1420.     END;
  1421.     IF numRegs = 1 THEN
  1422.       IF lastReg IN DataRegs THEN                     (* MOVE.L Dn, -(A7) *)
  1423.         op := SYS.LOR (2F00H, lastReg)
  1424.       ELSE                                            (* MOVE.L An, -(A7) *)
  1425.         op := SYS.LOR (2F08H, lastReg - 8)
  1426.       END;
  1427.       PutWord (op)
  1428.     ELSE                                         (* MOVEM.L <regs>, -(A7) *)
  1429.       (* Reverse the register list first *)
  1430.       reg := 0; rlist := {};
  1431.       WHILE reg <= lastReg DO
  1432.         IF reg IN regs THEN INCL (rlist, 15 - reg) END;
  1433.         INC (reg)
  1434.       END;
  1435.       PutWord (48E7H); PutWord (SYS.VAL (LONGINT, rlist))
  1436.     END
  1437.   END
  1438. END SaveRegisters0;
  1439.  
  1440. (*------------------------------------*)
  1441. PROCEDURE SaveRegisters *
  1442.   ( VAR saved : RegState;
  1443.     VAR x     : OCT.Item;
  1444.     mask      : SET );
  1445.  
  1446.   VAR r : INTEGER;
  1447.  
  1448. BEGIN (* SaveRegisters *)
  1449.   (* Temporarily reserve A4 and/or A5 if in mask *)
  1450.   regState.regs := regState.regs + (mask * {A4,A5});
  1451.   saved := regState; saved.regs := saved.regs * mask;
  1452.   IF x.mode IN {Reg, RegI, RegX} THEN EXCL (saved.regs, x.a0) END;
  1453.   IF x.mode IN {VarX, IndX, RegX} THEN EXCL (saved.regs, x.a2) END;
  1454.   SaveRegisters0 (saved.regs);
  1455.   regState.regs := regState.regs - saved.regs;
  1456.   FOR r := 0 TO 15 DO
  1457.     IF r IN saved.regs THEN regState.count[r] := 0 END;
  1458.   END
  1459. END SaveRegisters;
  1460.  
  1461. (*------------------------------------*)
  1462. PROCEDURE LoadRegParams1 * (VAR saved : RegState; VAR x : OCT.Item);
  1463.  
  1464.   VAR d0 : OCT.Item; inD0 : BOOLEAN; r : INTEGER;
  1465.  
  1466. BEGIN (* LoadRegParams1 *)
  1467.   inD0 := (x.mode = Reg) & (x.a0 = D0);
  1468.   saved := regState; saved.regs := saved.regs * ScratchRegs;
  1469.   IF inD0 THEN EXCL (saved.regs, D0) END;
  1470.   SaveRegisters0 (saved.regs);
  1471.   regState.regs := regState.regs - saved.regs;
  1472.   FOR r := 0 TO 15 DO
  1473.     IF r IN saved.regs THEN regState.count[r] := 0 END;
  1474.   END;
  1475.   IF ~inD0 THEN
  1476.     d0.mode := Reg; d0.a0 := D0; Move (x.typ^.size, x, d0)
  1477.   END
  1478. END LoadRegParams1;
  1479.  
  1480. (*------------------------------------*)
  1481. PROCEDURE LoadRegParams2 * (VAR saved : RegState; VAR x, y : OCT.Item);
  1482.  
  1483.   VAR d0, d1, t : OCT.Item; r : INTEGER;
  1484.  
  1485. BEGIN (* LoadRegParams2 *)
  1486.   saved := regState; saved.regs := saved.regs * ScratchRegs;
  1487.   IF (x.mode = Reg) & (x.a0 IN {D0, D1}) THEN EXCL (saved.regs, x.a0) END;
  1488.   IF (y.mode = Reg) & (y.a0 IN {D0, D1}) THEN EXCL (saved.regs, y.a0) END;
  1489.   SaveRegisters0 (saved.regs);
  1490.   regState.regs := regState.regs - saved.regs;
  1491.   FOR r := 0 TO 15 DO
  1492.     IF r IN saved.regs THEN regState.count[r] := 0 END;
  1493.   END;
  1494.   d0.mode := Reg; d0.a0 := D0; d1.mode := Reg; d1.a0 := D1;
  1495.   IF (y.mode = Reg) & (y.a0 = D0) THEN
  1496.     IF (x.mode = Reg) & (x.a0 = D1) THEN
  1497.       GetDReg (t, NIL); Move (x.typ^.size, x, t); x.a0 := t.a0;
  1498.       EXCL (regState.regs, D1); regState.count[D1] := 0
  1499.     END;
  1500.     Move (y.typ^.size, y, d1); y.a0 := D1;
  1501.     EXCL (regState.regs, D0); regState.count[D0] := 0;
  1502.     INCL (regState.regs, D1); regState.count[D1] := 1
  1503.   END;
  1504.   IF ~((x.mode = Reg) & (x.a0 = D0)) THEN Move (x.typ^.size, x, d0) END;
  1505.   IF ~((y.mode = Reg) & (y.a0 = D1)) THEN Move (y.typ^.size, y, d1) END
  1506. END LoadRegParams2;
  1507.  
  1508. (*------------------------------------*)
  1509. PROCEDURE CallKernel * ( proc : INTEGER );
  1510. BEGIN (* CallKernel *)
  1511.   IF OCM.SmallCode THEN
  1512.     PutWord (BSR); PutWordRef (0, kernelLab [proc])
  1513.   ELSE
  1514.     PutWord (JSR + 039H); PutLongRef (0, kernelLab [proc])
  1515.   END;
  1516. END CallKernel;
  1517.  
  1518. (*------------------------------------*)
  1519. PROCEDURE RestoreRegisters * (VAR saved : RegState; VAR x : OCT.Item);
  1520.  
  1521.   VAR
  1522.     numRegs, op, reg, lastReg : INTEGER; y : OCT.Item; rlist : SET;
  1523.     restyp : OCT.Struct;
  1524.  
  1525. BEGIN (* RestoreRegisters *)
  1526.   regState.regs := regState.regs + saved.regs;
  1527.   FOR reg := D0 TO A6 DO
  1528.     IF reg IN saved.regs THEN
  1529.       regState.obj[reg] := saved.obj[reg];
  1530.       regState.count[reg] := saved.count[reg]
  1531.     END;
  1532.   END;
  1533.  
  1534.   IF x.mode IN {XProc, LProc, TProc, M2Proc, CProc, AProc, CallBack} THEN
  1535.     restyp := x.typ
  1536.   ELSIF (x.mode IN {Var..RegX}) & (x.typ.form = ProcTyp) THEN
  1537.     restyp := x.typ.BaseTyp
  1538.   ELSE
  1539.     restyp := NIL
  1540.   END;
  1541.   IF
  1542.     (restyp # NIL) & (restyp.form = Pointer) & (restyp.size > OCM.PtrSize)
  1543.   THEN (* PROCEDURE return type is POINTER TO ARRAY OF ... *)
  1544.     reg := 0; rlist := {};
  1545.     WHILE (reg * 4) < restyp.size DO INCL (rlist, reg); INC (reg) END;
  1546.     IF (rlist * regState.regs) # {} THEN OCS.Mark (967) END;
  1547.     regState.regs := regState.regs + rlist;
  1548.     x.mode := RList; x.a0 := SYS.VAL (LONGINT, rlist)
  1549.   ELSE
  1550.     y := x; x.mode := Reg; x.a0 := D0;
  1551.     IF (D0 IN saved.regs) OR (y.mode = Reg) THEN
  1552.       IF (y.mode # Reg) OR ~(y.a0 IN DataRegs) THEN
  1553.         GetDReg (y, NIL)
  1554.       END;
  1555.       IF y.a0 # 0 THEN Move (L, x, y); x.a0 := y.a0 END;
  1556.     ELSE
  1557.       INCL (regState.regs, D0); regState.count[D0] := 1
  1558.     END
  1559.   END;
  1560.  
  1561.   IF saved.regs # {} THEN
  1562.     numRegs := 0; reg := 0;
  1563.     WHILE reg <= A7 DO
  1564.       IF reg IN saved.regs THEN lastReg := reg; INC (numRegs) END;
  1565.       INC (reg)
  1566.     END; (* WHILE *)
  1567.     IF numRegs = 1 THEN
  1568.       IF lastReg IN DataRegs THEN                     (* MOVE.L (A7)+, Dn *)
  1569.         op := SYS.LOR (201FH, SYS.LSH (lastReg, 9))
  1570.       ELSE                                           (* MOVEA.L (A7)+, An *)
  1571.         op := SYS.LOR (205FH, SYS.LSH (lastReg - 8, 9))
  1572.       END;
  1573.       PutWord (op)
  1574.     ELSE                                         (* MOVEM.L (A7)+, <regs> *)
  1575.       PutWord (4CDFH); PutWord (SYS.VAL (LONGINT, saved.regs))
  1576.     END
  1577.   END; (* IF *)
  1578.   regState.regs := regState.regs - {A4,A5} (* Mask out system registers *)
  1579. END RestoreRegisters;
  1580.  
  1581. (*------------------------------------*)
  1582. PROCEDURE fixup * (loc : LONGINT); (* enter pc at loc *)
  1583.  
  1584.   VAR offset : LONGINT;
  1585.  
  1586. BEGIN (* fixup *)
  1587.   IF genCode THEN
  1588.     offset := pc - loc;
  1589.     IF (offset < MIN (INTEGER)) OR (offset > MAX (INTEGER)) THEN
  1590.       OCS.Mark (955); offset := 0
  1591.     END;
  1592.     <*$ < NilChk- IndexChk- RangeChk- *>
  1593.     code [loc DIV 2] := SHORT (offset)
  1594.     <*$ > *>
  1595.   END
  1596. END fixup;
  1597.  
  1598. (*------------------------------------*)
  1599. PROCEDURE FixLink * (L : LONGINT);
  1600.  
  1601.   VAR L1 : LONGINT;
  1602.  
  1603. BEGIN (* FixLink *)
  1604.   IF genCode THEN
  1605.     WHILE L # 0 DO
  1606.       <*$ < NilChk- IndexChk- *>
  1607.       L1 := code [L DIV 2]; fixup (L); L := L1
  1608.       <*$ > *>
  1609.     END
  1610.   END
  1611. END FixLink;
  1612.  
  1613. (*------------------------------------*)
  1614. PROCEDURE FixupWith * (L, val : LONGINT);
  1615.  
  1616.   VAR x : LONGINT;
  1617.  
  1618. BEGIN (* FixupWith *)
  1619.   IF genCode THEN
  1620.     <*$ < NilChk- IndexChk- RangeChk- *>
  1621.     code [L DIV 2] := SHORT (val)
  1622.     <*$ > *>
  1623.   END
  1624. END FixupWith;
  1625.  
  1626. (*------------------------------------*)
  1627. PROCEDURE FixLinkWith * (L, val : LONGINT);
  1628.  
  1629.   VAR L1 : LONGINT;
  1630.  
  1631. BEGIN (* FixLinkWith *)
  1632.   IF genCode THEN
  1633.     WHILE L # 0 DO
  1634.       <*$ < NilChk- IndexChk- *>
  1635.       L1 := code [L DIV 2];
  1636.       <*$ > *>
  1637.       FixupWith (L, val - L); L := L1
  1638.     END
  1639.   END
  1640. END FixLinkWith;
  1641.  
  1642. (*------------------------------------*)
  1643. PROCEDURE MergedLinks * (L0, L1 : LONGINT): LONGINT;
  1644.  
  1645.   VAR L2, L3 : LONGINT;
  1646.  
  1647. BEGIN (* MergedLinks *)
  1648.   (* merge chains of the two operands of AND and OR *)
  1649.   IF L0 # 0 THEN
  1650.     IF genCode THEN
  1651.       L2 := L0;
  1652.       LOOP
  1653.         <*$ < NilChk- IndexChk- *>
  1654.         L3 := code [L2 DIV 2];
  1655.         <*$ > *>
  1656.         IF L3 = 0 THEN EXIT END;
  1657.         L2 := L3
  1658.       END; (* LOOP *)
  1659.       <*$ < NilChk- IndexChk- RangeChk- *>
  1660.       code [L2 DIV 2] := SHORT (L1);
  1661.       <*$ > *>
  1662.     END;
  1663.     RETURN L0
  1664.   ELSE
  1665.     RETURN L1
  1666.   END; (* ELSE *)
  1667. END MergedLinks;
  1668.  
  1669. (*------------------------------------*)
  1670. PROCEDURE invertedCC * (cc : LONGINT) : LONGINT;
  1671.  
  1672. BEGIN (* invertedCC *)
  1673.   IF ODD (cc) THEN RETURN cc - 1
  1674.   ELSE RETURN cc + 1
  1675.   END
  1676. END invertedCC;
  1677.  
  1678. (*------------------------------------*)
  1679. PROCEDURE Trap * (n : INTEGER);
  1680.  
  1681. BEGIN (* Trap *)
  1682.   IF n = OverflowCheck THEN
  1683.     PutWord (TRAPV);                             (*    TRAPV            *)
  1684.     PutWord (06008H);                            (*    BRA.S 1$         *)
  1685.   ELSE
  1686.     PutWord (TRAP + n)                           (*    TRAP  #n         *)
  1687.   END;
  1688.   IF OCM.Force THEN
  1689.     PutWord (NOP); PutWord (NOP); PutWord (NOP); PutWord (NOP)
  1690.   ELSE
  1691.     PutLongRef (0, OCT.ConstLabel);              (*    DC.L  ModuleName *)
  1692.     PutWord (OCS.line);                          (*    DC.W  line       *)
  1693.     PutWord (OCS.col);                           (*    DC.W  col        *)
  1694.   END;
  1695.                                                  (* 1$                  *)
  1696. END Trap;
  1697.  
  1698. (*------------------------------------*)
  1699. PROCEDURE TrapCC * (n, cc : INTEGER);
  1700.  
  1701. BEGIN (* TrapCC *)
  1702.   IF cc # T THEN
  1703.     (* Branch over the following TRAP instruction (10 bytes) *)
  1704.     PutWord (Bcc + (invertedCC (cc) * 100H) + 10)
  1705.   END;
  1706.   Trap (n)
  1707. END TrapCC;
  1708.  
  1709. (*------------------------------------*)
  1710. PROCEDURE TrapLink * ( n, cc : INTEGER; L : LONGINT );
  1711.  
  1712. BEGIN (* TrapLink *)
  1713.   IF cc # T THEN
  1714.     (* Branch over the following TRAP instruction (10 bytes) *)
  1715.     PutWord (Bcc + (invertedCC (cc) * 100H) + 10)(*    Bcc   2$         *)
  1716.   END;
  1717.   PatchWord (L, pc - L - 2); PutWord (TRAP + n); (* 1$ TRAP  #n         *)
  1718.   IF OCM.Force THEN
  1719.     PutWord (NOP); PutWord (NOP); PutWord (NOP); PutWord (NOP)
  1720.   ELSE
  1721.     PutLongRef (0, OCT.ConstLabel);              (*    DC.L  ModuleName *)
  1722.     PutWord (OCS.line);                          (*    DC.W  line       *)
  1723.     PutWord (OCS.col);                           (*    DC.W  col        *)
  1724.   END;
  1725.                                                  (* 2$                  *)
  1726. END TrapLink;
  1727.  
  1728. (*------------------------------------*)
  1729. PROCEDURE TypeTrap * ( L : LONGINT );
  1730.  
  1731. BEGIN (* TypeTrap *)
  1732.   PutWord (600AH);                               (*    BRA.S 1$         *)
  1733.   FixLink (L); PutWord (TRAP + TypeCheck);       (* L: TRAP  #TypeCheck *)
  1734.   IF OCM.Force THEN
  1735.     PutWord (NOP); PutWord (NOP); PutWord (NOP); PutWord (NOP)
  1736.   ELSE
  1737.     PutLongRef (0, OCT.ConstLabel);              (*    DC.L  ModuleName *)
  1738.     PutWord (OCS.line);                          (*    DC.W  line       *)
  1739.     PutWord (OCS.col);                           (*    DC.W  col        *)
  1740.   END;
  1741.                                                  (* 1$                  *)
  1742. END TypeTrap;
  1743.  
  1744. (*------------------------------------*)
  1745. PROCEDURE PutCHK* ( VAR bound : OCT.Item; reg : LONGINT );
  1746. BEGIN (* PutCHK *)
  1747.   PutF2 (CHK, bound, reg);
  1748.   PutWord (06008H);                              (*    BRA.S 1$         *)
  1749.   IF OCM.Force THEN
  1750.     PutWord (NOP); PutWord (NOP); PutWord (NOP); PutWord (NOP)
  1751.   ELSE
  1752.     PutLongRef (0, OCT.ConstLabel);              (*    DC.L  ModuleName *)
  1753.     PutWord (OCS.line);                          (*    DC.W  line       *)
  1754.     PutWord (OCS.col);                           (*    DC.W  col        *)
  1755.   END;
  1756.                                                  (* 1$                  *)
  1757. END PutCHK;
  1758.  
  1759. (*------------------------------------*)
  1760. PROCEDURE GlobalPtrs * () : BOOLEAN;
  1761.  
  1762.   VAR obj : OCT.Object;
  1763.  
  1764.   (*------------------------------------*)
  1765.   PROCEDURE FindPtrs (typ : OCT.Struct);
  1766.  
  1767.     VAR btyp : OCT.Struct; fld : OCT.Object; i, n : LONGINT;
  1768.  
  1769.   BEGIN (* FindPtrs *)
  1770.     IF
  1771.       ((typ.form = Pointer) & (typ.sysflg = OberonFlag))
  1772.       OR (typ.form = PtrTyp)
  1773.     THEN
  1774.       INC (numPtrs)
  1775.     ELSIF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  1776.       btyp := typ.BaseTyp; IF btyp # NIL THEN FindPtrs (btyp) END;
  1777.       fld := typ.link;
  1778.       WHILE fld # NIL DO
  1779.         IF fld.mode = Fld THEN
  1780.           IF fld.name < 0 THEN INC (numPtrs) (* Hidden pointer field *)
  1781.           ELSE FindPtrs (fld.typ)
  1782.           END;
  1783.         END;
  1784.         fld := fld.left
  1785.       END
  1786.     ELSIF typ.form = Array THEN
  1787.       btyp := typ.BaseTyp; n := typ.n;
  1788.       WHILE btyp.form = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END;
  1789.       IF btyp.form IN {Pointer, PtrTyp, Record} THEN
  1790.         i := 0; WHILE i < n DO FindPtrs (btyp); INC (i) END
  1791.       END
  1792.     END
  1793.   END FindPtrs;
  1794.  
  1795. BEGIN (* GlobalPtrs *)
  1796.   numPtrs := 0; obj := OCT.topScope.right;
  1797.   WHILE obj # NIL DO
  1798.     IF obj.mode = Var THEN FindPtrs (obj.typ) END;
  1799.     obj := obj.link
  1800.   END;
  1801.   RETURN (numPtrs # 0)
  1802. END GlobalPtrs;
  1803.  
  1804. (*------------------------------------*)
  1805. PROCEDURE NumProcs (typ : OCT.Struct) : LONGINT;
  1806.  
  1807.   VAR n : LONGINT; obj : OCT.Object;
  1808.  
  1809. BEGIN (* NumProcs *)
  1810.   n := 0;
  1811.   REPEAT
  1812.     obj := typ.link;
  1813.     WHILE obj # NIL DO
  1814.       IF (obj.mode = TProc) & (obj.a0 > n) THEN n := obj.a0 END;
  1815.       obj := obj.left
  1816.     END;
  1817.     typ := typ.BaseTyp
  1818.   UNTIL typ = NIL;
  1819.   RETURN n
  1820. END NumProcs;
  1821.  
  1822. (*------------------------------------*)
  1823. PROCEDURE ProcLab (typ : OCT.Struct; pno : LONGINT) : OCT.Label;
  1824.  
  1825.   VAR obj : OCT.Object;
  1826.  
  1827. BEGIN (* ProcLab *)
  1828.   LOOP
  1829.     obj := typ.link;
  1830.     WHILE obj # NIL DO
  1831.       IF (obj.mode = TProc) & (obj.a0 = pno) THEN
  1832.         RETURN obj.label
  1833.       END;
  1834.       obj := obj.left
  1835.     END;
  1836.     typ := typ.BaseTyp;
  1837.     IF typ = NIL THEN HALT (929) END
  1838.   END;
  1839. END ProcLab;
  1840.  
  1841.  
  1842. (*------------------------------------*)
  1843. PROCEDURE AllocSlots*;
  1844.  
  1845.   VAR
  1846.     slot, nextSlot : LONGINT; obj : OCT.Object; typ : OCT.Struct;
  1847.     i : INTEGER; pos1, pos2, offset : LONGINT;
  1848.  
  1849.   PROCEDURE FindSlot ( typ : OCT.Struct; name : LONGINT ) : LONGINT;
  1850.     VAR obj : OCT.Object;
  1851.   BEGIN (* FindSlot *)
  1852.     LOOP
  1853.       IF typ = NIL THEN RETURN -1 END;
  1854.       obj := typ.link;
  1855.       WHILE obj # NIL DO
  1856.         IF (obj.mode = TProc) & (obj.name = name) THEN RETURN obj.a0 END;
  1857.         obj := obj.left
  1858.       END;
  1859.       typ := typ.BaseTyp
  1860.     END
  1861.   END FindSlot;
  1862.  
  1863. BEGIN (* AllocSlots *)
  1864.   FOR i := 0 TO typex - 1 DO
  1865.     typ := type [i];
  1866.     IF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  1867.       nextSlot := OCT.NextProc (typ);
  1868.       obj := typ.link;
  1869.       WHILE obj # NIL DO
  1870.         IF (obj.mode = TProc) & (obj.a0 < 0) THEN
  1871.           slot := FindSlot (typ.BaseTyp, obj.name);
  1872.           IF slot < 0 THEN slot := nextSlot; INC (nextSlot) END;
  1873.           obj.a0 := slot; offset := slot * (-4);
  1874.           IF offset < MIN (INTEGER) THEN OCS.Mark (955); offset := 0 END;
  1875.           pos1 := obj.a2;
  1876.           WHILE pos1 # 1 DO
  1877.             <*$ < NilChk- IndexChk- RangeChk- *>
  1878.             pos2 := code [pos1 DIV 2]; code [pos1 DIV 2] := SHORT (offset);
  1879.             <*$ > *>
  1880.             pos1 := pos2
  1881.           END; (* WHILE *)
  1882.         END; (* IF *)
  1883.         obj := obj.left
  1884.       END; (* WHILE *)
  1885.     END; (* IF *)
  1886.   END (* FOR *)
  1887. END AllocSlots;
  1888.  
  1889.  
  1890. (*------------------------------------*)
  1891. PROCEDURE OutCode * (FName : ARRAY OF CHAR; key, datasize : LONGINT);
  1892.  
  1893.   VAR
  1894.     ObjFile : Files.File;
  1895.     out : Files.Rider;
  1896.     blockType, res, N : LONGINT;
  1897.     codeHunk : CodeHunk;
  1898.  
  1899.   (* ---------------------------------- *)
  1900.   PROCEDURE OutName (type : INTEGER; name : ARRAY OF CHAR);
  1901.  
  1902.     VAR len, char, pad : LONGINT;
  1903.  
  1904.   <*$CopyArrays-*>
  1905.   BEGIN (* OutName *)
  1906.     len := SYS.STRLEN (name);
  1907.     pad := (((len + 3) DIV 4) * 4) - len;
  1908.     N := SYS.LSH (LONG (type), 24) + ((len + 3) DIV 4);
  1909.     Files.WriteBytes (out, N, 4);
  1910.     char := 0;
  1911.     WHILE char < len DO
  1912.       Files.Write (out, name [char]);
  1913.       INC (char);
  1914.     END;
  1915.     WHILE pad > 0 DO Files.Write (out, 0X); DEC (pad) END;
  1916.   END OutName;
  1917.  
  1918.   (* ---------------------------------- *)
  1919.   PROCEDURE OutHunkUnit (name : ARRAY OF CHAR);
  1920.  
  1921.   <*$CopyArrays-*>
  1922.   BEGIN (* OutHunkUnit *)
  1923.     blockType := hunkUnit;
  1924.     Files.WriteBytes (out, blockType, 4);
  1925.     OutName (0, name);
  1926.   END OutHunkUnit;
  1927.  
  1928.   (*------------------------------------*)
  1929.   PROCEDURE OutHunkName (name : ARRAY OF CHAR);
  1930.  
  1931.   <*$CopyArrays-*>
  1932.   BEGIN (* OutHunkName *)
  1933.     blockType := hunkName;
  1934.     Files.WriteBytes (out, blockType, 4);
  1935.     OutName (0, name);
  1936.   END OutHunkName;
  1937.  
  1938.   (*------------------------------------*)
  1939.   PROCEDURE OutDef0 (label : ARRAY OF CHAR; offset : LONGINT);
  1940.  
  1941.   <*$CopyArrays-*>
  1942.   BEGIN (* OutDef0 *)
  1943.     OutName (extDef, label);
  1944.     Files.WriteBytes (out, offset, 4)
  1945.   END OutDef0;
  1946.  
  1947.   (*------------------------------------*)
  1948.   PROCEDURE OutDef (def : Def);
  1949.  
  1950.   BEGIN (* OutDef *)
  1951.     OutDef0 (def.object.label^, def.offset)
  1952.   END OutDef;
  1953.  
  1954.   (*------------------------------------*)
  1955.   PROCEDURE OutRef (ref : Ref);
  1956.  
  1957.     VAR type : INTEGER; offset : Offset;
  1958.  
  1959.   BEGIN (* OutRef *)
  1960.     IF ref.type = longRef THEN type := extRef32
  1961.     ELSIF ref.type = wordRef THEN type := extRef16
  1962.     ELSIF ref.type = smallRef THEN type := extDExt16
  1963.     ELSE OCS.Mark (959)
  1964.     END;
  1965.     OutName (type, ref.label^);
  1966.     Files.WriteBytes (out, ref.count, 4);
  1967.     offset := ref.offsets;
  1968.     WHILE offset # NIL DO
  1969.       Files.WriteBytes (out, offset.n, 4);
  1970.       offset := offset.next
  1971.     END
  1972.   END OutRef;
  1973.  
  1974.   (*------------------------------------*)
  1975.   PROCEDURE OutCodeHunk (codeHunk : CodeHunk);
  1976.  
  1977.     (*------------------------------------*)
  1978.     PROCEDURE OutHunkCode ();
  1979.  
  1980.       VAR pos, len : LONGINT; pad : INTEGER;
  1981.  
  1982.     BEGIN (* OutHunkCode *)
  1983.       blockType := hunkCode;
  1984.       Files.WriteBytes (out, blockType, 4);
  1985.  
  1986.       N := (codeHunk.length + 1) DIV 2;
  1987.       Files.WriteBytes (out, N, 4);
  1988.  
  1989.       pos := codeHunk.start; len := codeHunk.length;
  1990.       WHILE len > 0 DO
  1991.         <*$ < NilChk- IndexChk- *>
  1992.         Files.WriteBytes (out, code [pos], 2);
  1993.         <*$ > *>
  1994.         INC (pos); DEC (len);
  1995.       END; (* WHILE *)
  1996.  
  1997.       IF ODD (codeHunk.length) THEN
  1998.         pad := NOP; (* Output a NOP, purely for the benefit of ninfo *)
  1999.         Files.WriteBytes (out, pad, 2);
  2000.       END
  2001.     END OutHunkCode;
  2002.  
  2003.     (*------------------------------------*)
  2004.     PROCEDURE OutHunkExt ();
  2005.  
  2006.       VAR ref : Ref; def : Def;
  2007.  
  2008.     BEGIN (* OutHunkExt *)
  2009.       blockType := hunkExt; Files.WriteBytes (out, blockType, 4);
  2010.       IF codeHunk = InitCodeHunk THEN OutDef0 (OCT.InitLabel^, 0) END;
  2011.       def := codeHunk.defs;
  2012.       WHILE def # NIL DO OutDef (def); def := def.next END;
  2013.       ref := codeHunk.refs;
  2014.       WHILE ref # NIL DO OutRef (ref); ref := ref.next END;
  2015.       N := 0; Files.WriteBytes (out, N, 4)
  2016.     END OutHunkExt;
  2017.  
  2018.     (*------------------------------------*)
  2019.     PROCEDURE OutHunkSymbol ();
  2020.  
  2021.       VAR
  2022.         def : Def; obj : OCT.Object;
  2023.         name, symbol : ARRAY 256 OF CHAR;
  2024.  
  2025.     BEGIN (* OutHunkSymbol *)
  2026.       IF OCM.Debug & ((codeHunk = InitCodeHunk) OR (codeHunk.defs # NIL))
  2027.       THEN
  2028.         blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  2029.         IF codeHunk = InitCodeHunk THEN
  2030.           COPY (OCT.ModuleName, symbol); Str.Append ("_INIT-CODE", symbol);
  2031.           OutName (extSymb, symbol);
  2032.           N := 0; Files.WriteBytes (out, N, 4);
  2033.         END;
  2034.         def := codeHunk.defs;
  2035.         WHILE def # NIL DO
  2036.           obj := def.object;
  2037.           IF obj.mode = TProc THEN
  2038.             COPY (OCT.ModuleName, symbol); Str.Append ("_", symbol);
  2039.             OCT.GetName (obj.link.typ.strobj.name, name);
  2040.             Str.Append (name, symbol); Str.Append ("_", symbol);
  2041.             OCT.GetName (obj.name, name); Str.Append (name, symbol);
  2042.             OutName (extSymb, symbol)
  2043.           ELSIF obj.a0 = 0 THEN
  2044.             OutName (extSymb, obj.label^)
  2045.           ELSE
  2046.             COPY (obj.label^, symbol); Str.Append ("_", symbol);
  2047.             OCT.GetName (obj.name, name); Str.Append (name, symbol);
  2048.             OutName (extSymb, symbol)
  2049.           END;
  2050.           Files.WriteBytes (out, def.offset, 4);
  2051.           def := def.next
  2052.         END;
  2053.         N := 0; Files.WriteBytes (out, N, 4)
  2054.       END;
  2055.     END OutHunkSymbol;
  2056.  
  2057.   BEGIN (* OutCodeHunk *)
  2058.     OutHunkUnit (OCT.ModuleName);
  2059.     IF OCM.SmallCode THEN OutHunkName (hunkSmallCode)
  2060.     ELSE OutHunkName (OCT.ModuleName)
  2061.     END;
  2062.     OutHunkCode ();
  2063.     OutHunkExt ();
  2064.     OutHunkSymbol ();
  2065.     blockType := hunkEnd;
  2066.     Files.WriteBytes (out, blockType, 4);
  2067.   END OutCodeHunk;
  2068.  
  2069.   (*------------------------------------*)
  2070.   PROCEDURE OutConstants ();
  2071.  
  2072.     (*------------------------------------*)
  2073.     PROCEDURE OutHunkData ();
  2074.  
  2075.       VAR pos, len, pad : LONGINT;
  2076.  
  2077.     BEGIN (* OutHunkData *)
  2078.       IF OCM.Resident THEN blockType := hunkCode
  2079.       ELSE blockType := hunkData
  2080.       END;
  2081.       Files.WriteBytes (out, blockType, 4);
  2082.  
  2083.       N := (conx + 3) DIV 4;
  2084.       Files.WriteBytes (out, N, 4);
  2085.  
  2086.       pos := 0; len := conx;
  2087.       WHILE pos < len DO
  2088.         <*$ < NilChk- IndexChk- *>
  2089.         Files.Write (out, constant [pos]);
  2090.         <*$ > *>
  2091.         INC (pos);
  2092.       END; (* WHILE *)
  2093.  
  2094.       pad := (((len + 3) DIV 4) * 4) - len;
  2095.       WHILE pad > 0 DO
  2096.         Files.Write (out, 0X);
  2097.         DEC (pad);
  2098.       END; (* WHILE *)
  2099.     END OutHunkData;
  2100.  
  2101.     (*------------------------------------*)
  2102.     PROCEDURE OutHunkExt ();
  2103.  
  2104.       VAR ref : Ref;
  2105.  
  2106.     BEGIN (* OutHunkExt *)
  2107.       blockType := hunkExt;
  2108.       Files.WriteBytes (out, blockType, 4);
  2109.       OutDef0 (OCT.ConstLabel^, 0);
  2110.       N := 0;
  2111.       Files.WriteBytes (out, N, 4);
  2112.     END OutHunkExt;
  2113.  
  2114.     (*------------------------------------*)
  2115.     PROCEDURE OutHunkSymbol ();
  2116.  
  2117.     BEGIN (* OutHunkSymbol *)
  2118.       IF OCM.Debug THEN
  2119.         blockType := hunkSymbol;
  2120.         Files.WriteBytes (out, blockType, 4);
  2121.         OutName (extSymb, OCT.ConstLabel^);
  2122.         N := 0; Files.WriteBytes (out, N, 4);
  2123.         Files.WriteBytes (out, N, 4);
  2124.       END;
  2125.     END OutHunkSymbol;
  2126.  
  2127.   BEGIN (* OutConstants *)
  2128.     IF conx > 0 THEN
  2129.       OutHunkUnit (OCT.ModuleName);
  2130.       IF OCM.SmallData THEN OutHunkName (hunkMerged)
  2131.       ELSE OutHunkName (OCT.ModuleName)
  2132.       END;
  2133.       OutHunkData ();
  2134.       OutHunkExt ();
  2135.       OutHunkSymbol ();
  2136.       blockType := hunkEnd;
  2137.       Files.WriteBytes (out, blockType, 4);
  2138.     END; (* IF *)
  2139.   END OutConstants;
  2140.  
  2141.   (*------------------------------------*)
  2142.   PROCEDURE FindPtrs
  2143.     ( typ : OCT.Struct; adr : LONGINT; VAR offset : LONGINT );
  2144.  
  2145.     VAR btyp : OCT.Struct; fld : OCT.Object; i, n, s : LONGINT;
  2146.  
  2147.   BEGIN (* FindPtrs *)
  2148.     IF
  2149.       ((typ.form = Pointer) & (typ.sysflg = OberonFlag))
  2150.       OR (typ.form = PtrTyp)
  2151.     THEN
  2152.       Files.WriteBytes (out, adr, 4); DEC (offset, 4); INC (dataCount)
  2153.     ELSIF (typ.form = Record) & (typ.sysflg = OberonFlag) THEN
  2154.       btyp := typ.BaseTyp;
  2155.       IF btyp # NIL THEN FindPtrs (btyp, adr, offset) END;
  2156.       fld := typ.link;
  2157.       WHILE fld # NIL DO
  2158.         IF fld.mode = Fld THEN
  2159.           IF fld.name < 0 THEN (* Hidden pointer field *)
  2160.             n := fld.a0 + adr; Files.WriteBytes (out, n, 4);
  2161.             DEC (offset, 4); INC (dataCount)
  2162.           ELSE
  2163.             FindPtrs (fld.typ, fld.a0 + adr, offset)
  2164.           END
  2165.         END;
  2166.         fld := fld.left
  2167.       END;
  2168.     ELSIF typ.form = Array THEN
  2169.       btyp := typ.BaseTyp; n := typ.n;
  2170.       WHILE btyp.form = Array DO
  2171.         n := btyp.n * n; btyp := btyp.BaseTyp
  2172.       END;
  2173.       IF (btyp.form IN {Pointer, PtrTyp, Record}) THEN
  2174.         i := 0; s := btyp.size;
  2175.         WHILE i < n DO
  2176.           FindPtrs (btyp, i * s + adr, offset); INC (i)
  2177.         END
  2178.       END
  2179.     END
  2180.   END FindPtrs;
  2181.  
  2182.   (*------------------------------------*)
  2183.   PROCEDURE OutTypeDescs ();
  2184.  
  2185.     VAR i : INTEGER; numProcs : LONGINT;
  2186.  
  2187.     (*------------------------------------*)
  2188.     PROCEDURE OutHunkData (typ : OCT.Struct);
  2189.  
  2190.       VAR
  2191.         pos1, pos2, N, i, nameLen : LONGINT;
  2192.         name, objName : ARRAY 256 OF CHAR;
  2193.         ch : CHAR;
  2194.  
  2195.     BEGIN (* OutHunkData *)
  2196.       IF OCM.Resident THEN blockType := hunkCode
  2197.       ELSE blockType := hunkData
  2198.       END;
  2199.       Files.WriteBytes (out, blockType, 4);
  2200.       pos1 := Files.Pos (out);
  2201.       N := 0; Files.WriteBytes (out, N, 4);
  2202.       numProcs := NumProcs (typ); INC (dataCount, numProcs);
  2203.       i := numProcs;
  2204.       WHILE i > 0 DO Files.WriteBytes (out, N, 4); DEC (i) END;
  2205.       N := typ.size; Files.WriteBytes (out, N, 4);
  2206.       i := 0; N := 0;
  2207.       WHILE i < 16 DO Files.WriteBytes (out, N, 4); INC (i) END;
  2208.       INC (dataCount, 17);
  2209.       N := -68; FindPtrs (typ, 0, N); Files.WriteBytes (out, N, 4);
  2210.       IF typ.strobj # NIL THEN
  2211.         COPY (OCT.ModuleName, name); nameLen := SYS.STRLEN (name);
  2212.         name [nameLen] := "."; INC (nameLen);
  2213.         OCT.GetName (typ.strobj.name, objName);
  2214.         i := 0;
  2215.         REPEAT
  2216.           ch := objName [i]; name [nameLen] := ch;
  2217.           INC (i); INC (nameLen)
  2218.         UNTIL ch = 0X
  2219.       ELSE
  2220.         name := ""; nameLen := 1
  2221.       END;
  2222.       FOR i := 0 TO nameLen - 1 DO
  2223.         Files.Write (out, name [i]);
  2224.       END;
  2225.       WHILE (nameLen MOD 4) # 0 DO
  2226.         Files.Write (out, 0X); INC (nameLen)
  2227.       END;
  2228.       INC (dataCount, nameLen DIV 4);
  2229.       pos2 := Files.Pos (out);
  2230.       Files.Set (out, ObjFile, pos1);
  2231.       N := ((-N + nameLen) DIV 4) + numProcs + 1;
  2232.       Files.WriteBytes (out, N, 4);
  2233.       Files.Set (out, ObjFile, pos2);
  2234.     END OutHunkData;
  2235.  
  2236.     (*------------------------------------*)
  2237.     PROCEDURE OutHunkExt (typ : OCT.Struct);
  2238.  
  2239.       VAR N, i : LONGINT; lab : OCT.Label;
  2240.  
  2241.     BEGIN (* OutHunkExt *)
  2242.       N := hunkExt; Files.WriteBytes (out, N, 4);
  2243.       i := numProcs;
  2244.       WHILE i > 0 DO
  2245.         lab := ProcLab (typ, i); OutName (extRef32, lab^);
  2246.         N := 1; Files.WriteBytes (out, N, 4);
  2247.         N := (numProcs - i) * 4; Files.WriteBytes (out, N, 4);
  2248.         DEC (i)
  2249.       END;
  2250.       OutDef0 (typ.label^, numProcs * 4);
  2251.       IF typ.form = Record THEN
  2252.         WHILE (typ # NIL) & (typ.n >= 0) DO
  2253.           OutName (extRef32, typ.label^);
  2254.           N := 1; Files.WriteBytes (out, N, 4);
  2255.           N := (numProcs + typ.n + 1) * 4; Files.WriteBytes (out, N, 4);
  2256.           typ := typ.BaseTyp
  2257.         END;
  2258.       END;
  2259.       N := 0; Files.WriteBytes (out, N, 4)
  2260.     END OutHunkExt;
  2261.  
  2262.     (*------------------------------------*)
  2263.     PROCEDURE OutHunkSymbol (typ : OCT.Struct);
  2264.  
  2265.       VAR N, i : LONGINT; name, symbol : ARRAY 256 OF CHAR;
  2266.  
  2267.     BEGIN (* OutHunkSymbol *)
  2268.       IF OCM.Debug THEN
  2269.         N := hunkSymbol; Files.WriteBytes (out, N, 4);
  2270.         IF (typ.form = Record) & (typ.strobj # NIL) THEN
  2271.           COPY (OCT.ModuleName, symbol); Str.Append ("_", symbol);
  2272.           OCT.GetName (typ.strobj.name, name); Str.Append (name, symbol);
  2273.           OutName (extSymb, symbol)
  2274.         ELSE
  2275.           OutName (extSymb, typ.label^)
  2276.         END;
  2277.         N := numProcs * 4; Files.WriteBytes (out, N, 4);
  2278.         N := 0; Files.WriteBytes (out, N, 4)
  2279.       END;
  2280.     END OutHunkSymbol;
  2281.  
  2282.   BEGIN (* OutTypeDescs *)
  2283.     dataCount := 0;
  2284.     IF typex > 0 THEN
  2285.       i := 0;
  2286.       WHILE i < typex DO
  2287.         OutHunkUnit (OCT.ModuleName);
  2288.         IF OCM.SmallData THEN OutHunkName (hunkMerged)
  2289.         ELSE OutHunkName (OCT.ModuleName)
  2290.         END;
  2291.         OutHunkData (type [i]);
  2292.         OutHunkExt (type [i]);
  2293.         OutHunkSymbol (type [i]);
  2294.         blockType := hunkEnd;
  2295.         Files.WriteBytes (out, blockType, 4);
  2296.         INC (i)
  2297.       END
  2298.     END
  2299.   END OutTypeDescs;
  2300.  
  2301.   (*------------------------------------*)
  2302.   PROCEDURE OutGC ();
  2303.  
  2304.     VAR i : INTEGER;
  2305.  
  2306.     (*------------------------------------*)
  2307.     PROCEDURE OutHunkData ();
  2308.  
  2309.       VAR i, N : LONGINT; obj : OCT.Object;
  2310.  
  2311.     BEGIN (* OutHunkData *)
  2312.       IF OCM.Resident THEN N := hunkCode
  2313.       ELSE N := hunkData
  2314.       END;
  2315.       Files.WriteBytes (out, N, 4);
  2316.       N := numPtrs + 1; Files.WriteBytes (out, N, 4);
  2317.       obj := OCT.topScope.right;
  2318.       WHILE obj # NIL DO
  2319.         IF obj.mode = Var THEN FindPtrs (obj.typ, obj.a0, N) END;
  2320.         obj := obj.link
  2321.       END;
  2322.       N := -1; Files.WriteBytes (out, N, 4);
  2323.     END OutHunkData;
  2324.  
  2325.     (*------------------------------------*)
  2326.     PROCEDURE OutHunkExt ();
  2327.  
  2328.       VAR N : LONGINT;
  2329.  
  2330.     BEGIN (* OutHunkExt *)
  2331.       N := hunkExt; Files.WriteBytes (out, N, 4);
  2332.       OutDef0 (OCT.GCLabel^, 0);
  2333.       N := 0; Files.WriteBytes (out, N, 4)
  2334.     END OutHunkExt;
  2335.  
  2336.     (*------------------------------------*)
  2337.     PROCEDURE OutHunkSymbol ();
  2338.  
  2339.     BEGIN (* OutHunkSymbol *)
  2340.       IF OCM.Debug THEN
  2341.         blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  2342.         OutName (extSymb, OCT.GCLabel^);
  2343.         N := 0; Files.WriteBytes (out, N, 4);
  2344.         Files.WriteBytes (out, N, 4)
  2345.       END
  2346.     END OutHunkSymbol;
  2347.  
  2348.   BEGIN (* OutGC *)
  2349.     IF numPtrs > 0 THEN
  2350.       OutHunkUnit (OCT.ModuleName);
  2351.       IF OCM.SmallData THEN OutHunkName (hunkMerged)
  2352.       ELSE OutHunkName (OCT.ModuleName)
  2353.       END;
  2354.       OutHunkData ();
  2355.       OutHunkExt ();
  2356.       OutHunkSymbol ();
  2357.       blockType := hunkEnd; Files.WriteBytes (out, blockType, 4)
  2358.     END
  2359.   END OutGC;
  2360.  
  2361.   (*------------------------------------*)
  2362.   PROCEDURE OutVars ();
  2363.  
  2364.   BEGIN (* OutVars *)
  2365.     OutHunkUnit (OCT.ModuleName);
  2366.     IF (OCM.SmallData OR OCM.Resident) THEN OutHunkName (hunkMerged)
  2367.     ELSE OutHunkName (OCT.ModuleName)
  2368.     END;
  2369.  
  2370.     blockType := hunkBSS;
  2371.     Files.WriteBytes (out, blockType, 4);
  2372.  
  2373.     N := (datasize + 3) DIV 4;
  2374.     Files.WriteBytes (out, N, 4);
  2375.  
  2376.     blockType := hunkExt;
  2377.     Files.WriteBytes (out, blockType, 4);
  2378.     OutDef0 (OCT.VarLabel^, 0);
  2379.     N := 0; Files.WriteBytes (out, N, 4);
  2380.  
  2381.     IF OCM.Debug THEN
  2382.       blockType := hunkSymbol; Files.WriteBytes (out, blockType, 4);
  2383.       OutName (extSymb, OCT.VarLabel^);
  2384.       N := 0; Files.WriteBytes (out, N, 4);
  2385.       Files.WriteBytes (out, N, 4);
  2386.     END;
  2387.  
  2388.     blockType := hunkEnd; Files.WriteBytes (out, blockType, 4)
  2389.   END OutVars;
  2390.  
  2391. <*$CopyArrays-*>
  2392. BEGIN (* OutCode *)
  2393.   IF OCM.Force OR ~OCS.scanerr THEN
  2394.     ObjFile := Files.New (FName);
  2395.     IF ObjFile # NIL THEN
  2396.       Files.Set (out, ObjFile, 0);
  2397.  
  2398.       codeHunk := FirstCodeHunk;
  2399.       WHILE codeHunk # NIL DO
  2400.         OutCodeHunk (codeHunk);
  2401.         codeHunk := codeHunk.next;
  2402.       END; (* WHILE *)
  2403.       OutConstants ();
  2404.       OutTypeDescs ();
  2405.       OutGC ();
  2406.       OutVars ();
  2407.  
  2408.       Files.Set (out, NIL, 0); Files.Register (ObjFile);
  2409.       OCM.MakeIcon (FName, OCM.iconObj)
  2410.     ELSE
  2411.       OCS.Mark (153)
  2412.     END
  2413.   END;
  2414. END OutCode;
  2415.  
  2416. (*------------------------------------*)
  2417. PROCEDURE DataSize * () : LONGINT;
  2418.  
  2419.   VAR size : LONGINT;
  2420.  
  2421. BEGIN (* DataSize *)
  2422.   size := dataCount * 4 + conx;
  2423.   RETURN size;
  2424. END DataSize;
  2425.  
  2426. BEGIN (* OCC *)
  2427.   FirstCodeHunk := NIL; CurrCodeHunk := NIL; InitCodeHunk := NIL;
  2428.   Prologue := NIL; NEW (wasderef);
  2429.  
  2430.   FOR i := 0 TO (numKProcs - 1) DO NEW (kernelLab [i], 32) END;
  2431.   COPY ("Kernel_Halt",            kernelLab [kHalt]^);
  2432.   COPY ("Kernel_NewRecord",       kernelLab [kNewRecord]^);
  2433.   COPY ("Kernel_NewArray",        kernelLab [kNewArray]^);
  2434.   COPY ("Kernel_NewSysBlk",       kernelLab [kNewSysBlk]^);
  2435.   COPY ("Kernel_Dispose",         kernelLab [kDispose]^);
  2436.   COPY ("Kernel_InitGC",          kernelLab [kInitGC]^);
  2437.   COPY ("Kernel_Move",            kernelLab [kMove]^);
  2438.   COPY ("Kernel_StackChk",        kernelLab [kStackChk]^);
  2439.   COPY ("Kernel_Mul32",           kernelLab [kMul32]^);
  2440.   COPY ("Kernel_Div32",           kernelLab [kDiv32]^);
  2441.   COPY ("Kernel_SPFix",           kernelLab [kSPFix]^);
  2442.   COPY ("Kernel_SPFlt",           kernelLab [kSPFlt]^);
  2443.   COPY ("Kernel_SPCmp",           kernelLab [kSPCmp]^);
  2444.   COPY ("Kernel_SPTst",           kernelLab [kSPTst]^);
  2445.   COPY ("Kernel_SPNeg",           kernelLab [kSPNeg]^);
  2446.   COPY ("Kernel_SPAdd",           kernelLab [kSPAdd]^);
  2447.   COPY ("Kernel_SPSub",           kernelLab [kSPSub]^);
  2448.   COPY ("Kernel_SPMul",           kernelLab [kSPMul]^);
  2449.   COPY ("Kernel_SPDiv",           kernelLab [kSPDiv]^);
  2450.   COPY ("Kernel_SPAbs",           kernelLab [kSPAbs]^);
  2451.   COPY ("Kernel_END",             kernelLab [kEnd]^);
  2452.   COPY ("Kernel_RegisterModule",  kernelLab [kRegisterModule]^);
  2453.   COPY ("Kernel_RegisterType",    kernelLab [kRegisterType]^);
  2454.   COPY ("Kernel_RegisterCommand", kernelLab [kRegisterCommand]^);
  2455. END OCC.
  2456.  
  2457. (*************************************************************************
  2458.  
  2459.   $Log: OCC.mod $
  2460.   Revision 5.23  1995/07/14  00:42:12  fjc
  2461.   - Tried to make the genCode flag work, but failed :-(.
  2462.  
  2463.   Revision 5.22  1995/06/15  18:12:19  fjc
  2464.   - Changed register allocation to use A6 more.
  2465.  
  2466.   Revision 5.21  1995/06/03  00:35:29  fjc
  2467.   - Fixed incorrect error number.
  2468.  
  2469.   Revision 5.20  1995/06/02  18:36:28  fjc
  2470.   - Added genCode flag variable.
  2471.   - Various changes to implementation of SMALLDATA and
  2472.     RESIDENT options.
  2473.  
  2474.   Revision 5.19  1995/05/19  16:01:52  fjc
  2475.   - Uses OCOut for console IO.
  2476.  
  2477.   Revision 5.18  1995/05/13  23:03:59  fjc
  2478.   - Changes to allow code to be >32K.
  2479.  
  2480.   Revision 5.17  1995/04/13  18:15:35  fjc
  2481.   *** empty log message ***
  2482.  
  2483.   Revision 5.16  1995/04/02  13:42:55  fjc
  2484.   - Numerous changes to implement the small data model.
  2485.  
  2486.   Revision 5.15  1995/03/23  18:07:23  fjc
  2487.   - Fixes to register allocation and deallocation.
  2488.  
  2489.   Revision 5.14  1995/03/13  11:24:55  fjc
  2490.   - Changed register allocations procedures to allocate A6 as
  2491.     a last resort.
  2492.   - Added count field to RegState type and modified register
  2493.     handling procedures to maintain it.
  2494.  
  2495.   Revision 5.13  1995/03/09  19:07:23  fjc
  2496.   - Incorporated changes from 5.22.
  2497.  
  2498.   Revision 5.12  1995/02/27  16:57:34  fjc
  2499.   - Removed tracing code.
  2500.   - Implemented SMALLCODE option.
  2501.   - Modified register handling code to remember which object
  2502.     is loaded into a particular register.
  2503.  
  2504.   Revision 5.11.1.2  1995/03/08  18:54:55  fjc
  2505.   - OC 5.22
  2506.  
  2507.   Revision 5.11.1.1  1995/02/27  19:11:17  fjc
  2508.   - Fixed code buffer overflow bug.
  2509.  
  2510.   Revision 5.11  1995/01/26  00:17:17  fjc
  2511.   - Release 1.5
  2512.  
  2513.   Revision 5.10  1995/01/09  13:54:08  fjc
  2514.   - Added call to OCM.MakeIcon().
  2515.  
  2516.   Revision 5.9  1995/01/05  11:32:29  fjc
  2517.   - Changed to force output of object files if OCM.Force is TRUE.
  2518.  
  2519.   Revision 5.8  1995/01/03  21:16:57  fjc
  2520.   - Changed OCG to OCM.
  2521.  
  2522.   Revision 5.7  1994/12/16  17:15:03  fjc
  2523.   - Changed to accomodate renaming OCT.Symbol to OCT.Label.
  2524.   - Added AllocSlots() to fix a serious bug that caused the
  2525.     wrong slots to be allocated for type-bound procedures.
  2526.   - Symbols output in object file are now different to the
  2527.     corresponding linker labels in some cases.
  2528.  
  2529.   Revision 5.6  1994/11/13  11:23:46  fjc
  2530.   - Added kSPAbs.
  2531.  
  2532.   Revision 5.5  1994/10/23  15:51:42  fjc
  2533.   - Added kernelLab array and CallKernel().
  2534.   - Fixed bug that made SYSTEM.PTR variables untraced.
  2535.  
  2536.   Revision 5.4  1994/09/25  17:43:15  fjc
  2537.   - Changed to reflect new object modes and system flags.
  2538.  
  2539.   Revision 5.3  1994/09/15  10:24:29  fjc
  2540.   - Replaced switches with pragmas.
  2541.  
  2542.   Revision 5.2  1994/09/08  10:47:13  fjc
  2543.   - Changed to use pragmas/options.
  2544.  
  2545.   Revision 5.1  1994/09/03  19:29:08  fjc
  2546.   - Bumped version number
  2547.  
  2548. *************************************************************************)
  2549.